home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 101-125 / disk_104 / analyticalc / src / analysrc.arc / AnalyTZ.Ftn < prev    next >
Text File  |  1987-10-06  |  93KB  |  3,223 lines
  1. c -h- test.for    Fri Aug 22 13:35:58 1986    
  2.     SUBROUTINE TEST(LOGTYP,FLAG,V1,V2)
  3.     InTeGer*4 FLAG
  4.     REAL*8 V1,V2
  5.     FLAG=0
  6.     IF(LOGTYP.EQ.1.AND.V1.GT.V2)FLAG=1
  7.     IF(LOGTYP.EQ.2.AND.V1.LT.V2)FLAG=1
  8.     IF(LOGTYP.EQ.3.AND.V1.EQ.V2)FLAG=1
  9.     IF(LOGTYP.EQ.4.AND.V1.NE.V2)FLAG=1
  10.     IF(LOGTYP.EQ.5.AND.V1.GE.V2)FLAG=1
  11.     IF(LOGTYP.EQ.6.AND.V1.LE.V2)FLAG=1
  12. C TEST LOGICAL RELATIONS FOR IF STATEMENT, FLAG=1 IF TRUE, 0 ELSE.
  13.     RETURN
  14.     END
  15. c -h- ttydei.for    Fri Aug 22 13:35:58 1986    
  16.     SUBROUTINE TTYDEI
  17.     INCLUDE DOS.INC
  18.     INTEGER *4 MODE
  19.     Integer*4 Amiga
  20.     External Amiga
  21. C ***<<< XVXTCD COMMON START >>>***
  22.     CHARACTER*1 OARRY(100)
  23.     InTeGer*4 OSWIT,OCNTR
  24. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  25. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  26.     InTeGer*4 IPS1,IPS2,MODFLG
  27. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  28.        InTeGer*4 XTCFG,IPSET,XTNCNT
  29.        CHARACTER*1 XTNCMD(80)
  30. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  31. C VARY FLAG ITERATION COUNT
  32.     INTEGER KALKIT
  33. C    COMMON/VARYIT/KALKIT
  34.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  35.     InTeGer*4 RCMODE,IRCE1,IRCE2
  36. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  37. C     1  IRCE2
  38. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  39. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  40. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  41. C RCFGX ON.
  42. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  43. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  44. C  AND VM INHIBITS. (SETS TO 1).
  45.     INTEGER*4 FH
  46. C FILE HANDLE FOR CONSOLE I/O (RAW)
  47. C    COMMON/CONSFH/FH
  48.     CHARACTER*1 ARGSTR(52,4)
  49. C    COMMON/ARGSTR/ARGSTR
  50.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  51.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  52.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  53.      3  IRCE2,FH,ARGSTR
  54. C ***<<< XVXTCD COMMON END >>>***
  55. CCC    COMMON/CONSFH/FH
  56.     If (FH.ne.0)Call Amiga(Close,FH)
  57.     RETURN
  58.     END
  59. c -h- ttyini.for    Fri Aug 22 13:35:58 1986    
  60.     SUBROUTINE TTYINI
  61. C PERFORM INITS ON UNIT 5. NORMALLY EITHER DO NOTHING OR
  62. C REPLACE WITH SOMETHING THAT WORKS FOR YOUR SYSTEM. TYPICAL
  63. C ACTIONS:
  64. C  SET THE TERMINAL NOT TO WRAP AROUND
  65. C  ATTACH TERMINAL SO TYPE-AHEAD WORKS
  66. C  SET UP TERMINAL TO MUNGE AROUND THE ESCAPE SEQUENCES TO ALLOW
  67. C  SPECIAL FUNCTION AND/OR ARROW KEYS TO WORK.
  68. C ULTIMATELY USE WRITE OF UNIT 0 TO DUMP OUT SOME USEFUL ESCAPE SEQS.
  69. C TO DEFINE FUNCTION KEYS A LA VT100 (SORT OF).
  70.     INCLUDE DOS.INC
  71.     CHARACTER*40 NAME
  72.     INTEGER *4 MODE
  73.     Integer*4 Amiga
  74.     External Amiga
  75. C ***<<< XVXTCD COMMON START >>>***
  76.     CHARACTER*1 OARRY(100)
  77.     InTeGer*4 OSWIT,OCNTR
  78. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  79. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  80.     InTeGer*4 IPS1,IPS2,MODFLG
  81. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  82.        InTeGer*4 XTCFG,IPSET,XTNCNT
  83.        CHARACTER*1 XTNCMD(80)
  84. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  85. C VARY FLAG ITERATION COUNT
  86.     INTEGER KALKIT
  87. C    COMMON/VARYIT/KALKIT
  88.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  89.     InTeGer*4 RCMODE,IRCE1,IRCE2
  90. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  91. C     1  IRCE2
  92. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  93. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  94. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  95. C RCFGX ON.
  96. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  97. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  98. C  AND VM INHIBITS. (SETS TO 1).
  99.     INTEGER*4 FH
  100. C FILE HANDLE FOR CONSOLE I/O (RAW)
  101. C    COMMON/CONSFH/FH
  102.     CHARACTER*1 ARGSTR(52,4)
  103. C    COMMON/ARGSTR/ARGSTR
  104.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  105.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  106.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  107.      3  IRCE2,FH,ARGSTR
  108. C ***<<< XVXTCD COMMON END >>>***
  109. CCC    COMMON/CONSFH/FH
  110.     NAME="CON:0/0/600/199/AnalytiCalc-AMIGA" // CHAR(0)
  111.     MODE=MODE_OLDFILE
  112.     FH=AMIGA(Open,NAME,MODE)
  113.     RETURN
  114.     END
  115. c -h- typget.for    Fri Aug 22 13:35:58 1986    
  116.         SUBROUTINE TYPGET(ID1,ID2,IVAL)
  117. C
  118. C TYPGET - GET TYPE(60,301) ARRAY WORDS BACK
  119. C RETURN TYPE(ID1,ID2) IN IVAL, BUT NOT REALLY...
  120. C NEXT BITMAPS IMPLEMENT FVLD
  121.         CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
  122.     CHARACTER*1 FVXX(6792)
  123.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
  124.     EQUIVALENCE (FV4(1),FVXX(4529))
  125.         Common/FVLDM/FVXX
  126. c        COMMON/FVLDM/FV1,FV2,FV4
  127.         CHARACTER*1 LBITS(8)
  128.         COMMON/BITS/LBITS
  129. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  130. C TYPES OF AC'S STORAGE:
  131.     LOGICAL*4 LB1,LB2
  132.     InTeGer*4 KB1,KB2
  133.     EQUIVALENCE(LB1,KB1),(LB2,KB2)
  134.         CHARACTER*1 ITYP(2264)
  135.         InTeGer*4 IATYP(27),LINTGR
  136.         COMMON/TYP/IATYP,ITYP,LINTGR
  137. C ***<<< NULETC COMMON START >>>***
  138.     InTeGer*4 ICREF,IRREF
  139. C    COMMON/MIRROR/ICREF,IRREF
  140.     InTeGer*4 MODPUB,LIMODE
  141. C    COMMON/MODPUB/MODPUB,LIMODE
  142.     InTeGer*4 KLKC,KLKR
  143.     REAL*8 AACP,AACQ
  144. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  145.     InTeGer*4 NCEL,NXINI
  146. C    COMMON/NCEL/NCEL,NXINI
  147.     CHARACTER*1 NAMARY(20,301)
  148. C    COMMON/NMNMNM/NAMARY
  149.     InTeGer*4 NULAST,LFVD
  150. C    COMMON/NULXXX/NULAST,LFVD
  151.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  152.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  153. C ***<<< NULETC COMMON END >>>***
  154. CCC    InTeGer*4 ICREF,IRREF
  155. CCC    COMMON/MIRROR/ICREF,IRREF
  156. C
  157. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  158. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  159. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  160. C AREAS WITH DATA.
  161. C ***<<< KLSTO COMMON START >>>***
  162.     InTeGer*4 DLFG
  163. C    COMMON/DLFG/DLFG
  164.     InTeGer*4 KDRW,KDCL
  165. C    COMMON/DOT/KDRW,KDCL
  166.     InTeGer*4 DTRENA
  167. C    COMMON/DTRCMN/DTRENA
  168.     REAL*8 EP,PV,FV
  169.     DIMENSION EP(20)
  170.     INTEGER*4 KIRR
  171. C    COMMON/ERNPER/EP,PV,FV,KIRR
  172.     InTeGer*4 LASTOP
  173. C    COMMON/ERROR/LASTOP
  174.     CHARACTER*1 FMTDAT(9,76)
  175. C    COMMON/FMTBFR/FMTDAT
  176.     CHARACTER*1 EDNAM(16)
  177. C    COMMON/EDNAM/EDNAM
  178.     InTeGer*4 MFID(2),MFMOD(2)
  179. C    COMMON/FRM/MFID,MFMOD
  180.     InTeGer*4 JMVFG,JMVOLD
  181. C    COMMON/FUBAR/JMVFG,JMVOLD
  182.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  183.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  184. C ***<<< KLSTO COMMON END >>>***
  185. CCC        CHARACTER*1 FMTDAT(9,76)
  186. CCC        COMMON/FMTBFR/FMTDAT
  187.         CHARACTER*1 ITST,ITST2
  188.     LOGICAL*4 LTST,LTST2
  189.     InTeGer*4 KTST,KTST2
  190.     EQUIVALENCE(LTST,ITST),(LTST2,ITST2)
  191.     EQUIVALENCE(KTST,ITST),(KTST2,ITST2)
  192.         IF(ID1.LE.27.AND.ID2.LE.1)GOTO 1000
  193.     IVAL=2
  194.     IF(LINTGR.EQ.0)RETURN
  195.     CALL FVLDGT(ID1,ID2,ITST)
  196.     IF(ICHAR(ITST).EQ.0)GOTO 500
  197. C        ID=(ID2-1)*60+ID1
  198.     CALL REFLEC(ID2,ID1,ID)
  199.         IBT=(ID-1)/8
  200.     KB1=ID-1
  201.     KB2=7
  202.     LB1=LB1.AND.LB2
  203.     IBIT=KB1+1
  204. C        IBIT=((ID-1).AND.7)+1
  205.     KTST=ICHAR(ITYP(IBT))
  206.     KTST2=ICHAR(LBITS(IBIT))
  207.     LTST=LTST.AND.LTST2
  208. C        ITST=CHAR(ICHAR(ITYP(IBT)).AND.ICHAR(LBITS(IBIT)))
  209. 500     IVAL=2
  210.         IF(KTST.NE.0)IVAL=4
  211.         RETURN
  212. 1000    CONTINUE
  213. C AN AC. RETURN FULL TYPE WORD
  214.         IVAL=IATYP(ID1)
  215.         RETURN
  216.         END
  217. c -h- typset.for    Fri Aug 22 13:35:58 1986    
  218.         SUBROUTINE TYPSET(ID1,ID2,IVAL)
  219. C
  220. C TYPSET - STORE IVAL IN TYPE(60,301) ARRAY
  221. C NEXT BITMAPS IMPLEMENT FVLD
  222.         CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
  223.     CHARACTER*1 FVXX(6792)
  224.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
  225.     EQUIVALENCE (FV4(1),FVXX(4529))
  226.         Common/FVLDM/FVXX
  227. c        COMMON/FVLDM/FV1,FV2,FV4
  228.         CHARACTER*1 LBITS(8)
  229.         COMMON/BITS/LBITS
  230. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  231. C TYPES OF AC'S STORAGE:
  232.     LOGICAL*4 LTST,LTST2,LTST3,LT1,LT2
  233.     InTeGer*4 KTST,KTST2,KTST3,KT1,KT2
  234.     EQUIVALENCE(LT1,KT1),(LT2,KT2)
  235.         CHARACTER*1 ITYP(2264)
  236.         InTeGer*4 IATYP(27),LINTGR
  237.         COMMON/TYP/IATYP,ITYP,LINTGR
  238. C ***<<< NULETC COMMON START >>>***
  239.     InTeGer*4 ICREF,IRREF
  240. C    COMMON/MIRROR/ICREF,IRREF
  241.     InTeGer*4 MODPUB,LIMODE
  242. C    COMMON/MODPUB/MODPUB,LIMODE
  243.     InTeGer*4 KLKC,KLKR
  244.     REAL*8 AACP,AACQ
  245. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  246.     InTeGer*4 NCEL,NXINI
  247. C    COMMON/NCEL/NCEL,NXINI
  248.     CHARACTER*1 NAMARY(20,301)
  249. C    COMMON/NMNMNM/NAMARY
  250.     InTeGer*4 NULAST,LFVD
  251. C    COMMON/NULXXX/NULAST,LFVD
  252.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  253.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  254. C ***<<< NULETC COMMON END >>>***
  255. CCC    InTeGer*4 ICREF,IRREF
  256. CCC    COMMON/MIRROR/ICREF,IRREF
  257. C
  258. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  259. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  260. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  261. C AREAS WITH DATA.
  262. C ***<<< KLSTO COMMON START >>>***
  263.     InTeGer*4 DLFG
  264. C    COMMON/DLFG/DLFG
  265.     InTeGer*4 KDRW,KDCL
  266. C    COMMON/DOT/KDRW,KDCL
  267.     InTeGer*4 DTRENA
  268. C    COMMON/DTRCMN/DTRENA
  269.     REAL*8 EP,PV,FV
  270.     DIMENSION EP(20)
  271.     INTEGER*4 KIRR
  272. C    COMMON/ERNPER/EP,PV,FV,KIRR
  273.     InTeGer*4 LASTOP
  274. C    COMMON/ERROR/LASTOP
  275.     CHARACTER*1 FMTDAT(9,76)
  276. C    COMMON/FMTBFR/FMTDAT
  277.     CHARACTER*1 EDNAM(16)
  278. C    COMMON/EDNAM/EDNAM
  279.     InTeGer*4 MFID(2),MFMOD(2)
  280. C    COMMON/FRM/MFID,MFMOD
  281.     InTeGer*4 JMVFG,JMVOLD
  282. C    COMMON/FUBAR/JMVFG,JMVOLD
  283.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  284.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  285. C ***<<< KLSTO COMMON END >>>***
  286. CCC        CHARACTER*1 FMTDAT(9,76)
  287. CCC        COMMON/FMTBFR/FMTDAT
  288.         CHARACTER*1 ITST,ITST2,ITST3
  289.     EQUIVALENCE(LTST,ITST),(LTST2,ITST2)
  290.     EQUIVALENCE(KTST,ITST),(KTST2,ITST2)
  291.     EQUIVALENCE(KTST3,ITST3),(KTST3,LTST3)
  292.     IF(ID2.EQ.1.AND.ID1.LE.27)GOTO 2000
  293. C KEEP TRACK OF WHEN WE START TO SET INTEGER TYPE
  294.     IF(LINTGR.EQ.0.AND.IABS(IVAL).EQ.2)RETURN
  295. C FOR SIMPLICITY SET FLAG ON 1ST NONFLOATING TYPE AND
  296. C START KEEPING EXACT TRACK THEN ONLY.
  297.     LINTGR=1
  298. C        ID=(ID2-1)*60+ID1
  299.     CALL REFLEC(ID2,ID1,ID)
  300.         IBT=(ID-1)/8
  301.     KT1=ID-1
  302.     KT2=7
  303.     LT1=LT1.AND.LT2
  304.     IBIT=KT1+1
  305. C        IBIT=((ID-1).AND.7)+1
  306.     KTST2=ICHAR(LBITS(IBIT))
  307.     KTST3=KTST2
  308.     LTST2=.NOT.LTST2
  309. C        ITST2=.NOT.LBITS(IBIT)
  310.     KTST=ICHAR(ITYP(IBT))
  311.     LTST2=LTST.AND.LTST2
  312. C        ITST2=ITYP(IBT).AND.ITST2
  313.     LTST=LTST.OR.LTST3
  314.     ITST=CHAR(KTST)
  315.     ITST2=CHAR(KTST2)
  316. C        ITST=ITYP(IBT).OR.LBITS(IBIT)
  317.         ITYP(IBT)=ITST2
  318.         IF(IVAL.NE.-2.AND.IVAL.NE.2)ITYP(IBT)=ITST
  319.     RETURN
  320. 2000    IATYP(ID1)=IVAL
  321. C ACCUMULATORS JUST STORE NORMAL TYPE INTEGER.
  322.         RETURN
  323.         END
  324. c -h- usrcmd.for    Fri Aug 22 13:36:30 1986    
  325. c        interface to InTeGer*4 function system [c]
  326. c     +          (string[reference])
  327. c        character*1 string
  328. c        end
  329.     SUBROUTINE USRCMD(CMDLIN,ICODE,IGOTIT)
  330. C --- FOR 320K AnalytiCalc only (to keep it able to fit on 256K
  331. c     versions...)
  332. c Add "annotation" commands via main force & awkwardness as follows:
  333. c  1. ANN command will create a file named cell.ANN for the current
  334. c     cell (or overwrite an old one) dynamically for up to 20 lines
  335. c     of text, just firing up the command "EDIT namecell.ANN" so the user
  336. c     gets to do full screen edits. THE "name" part of the files is
  337. c     taken from the first 6 characters of the sheet name. If these
  338. c     are not in the uppercase alpha range they will be ignored, however,
  339. c     so it is a good idea for sheet titles to have recognizable initial
  340. c     6 characters.
  341. c  2. QUERY or ? command will display the name.ANN file if it exists
  342. c     after setting cursor to top of screen and doing line erase
  343. c     there.
  344. c
  345.     CHARACTER*81 CMDSTR
  346.     CHARACTER*1 CMLN(80),CMLN2(84)
  347. C    PARAMETER CUP=1,EL=12,ED=11,SGR=13
  348.     InTeGer*4 IJUNK
  349. c    InTeGer*4 SYSTEM
  350. c    EXTERNAL SYSTEM
  351.     EQUIVALENCE(CMLN2(5),CMLN(1),CMDSTR(1:1))
  352. C    EQUIVALENCE(CMLN2(5),CMLN(1))
  353. C DUMMY PLACE FOR USER COMMANDS TO PARSE CMDLIN AND HANDLE
  354. C DEFINE VALUE AREA FOR SPREAD SHEET. MORE WILL BE NEEDED GENERALLY
  355. C OUT OF COMMONS, BUT AT A MINIMUM, THIS WILL ALLOW SOME ACCESS TO
  356. C USEFUL NUMBERS. LOOK IN XQTCMD FOR MORE...
  357.     CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
  358.     InTeGer*4 TYPE(1,1),VLEN(9)
  359.     LOGICAL*4 LEXIST
  360.     CHARACTER*1 NMSH(80)
  361.     COMMON/NMSH/NMSH
  362. C ***<<<< RDD COMMON START >>>***
  363.     InTeGer*4 RRWACT,RCLACT
  364. C    COMMON/RCLACT/RRWACT,RCLACT
  365.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  366.      1  IDOL7,IDOL8
  367. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  368. C     1  IDOL7,IDOL8
  369.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  370. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  371.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  372. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  373. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  374. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  375.     InTeGer*4 KLVL
  376. C    COMMON/KLVL/KLVL
  377.     InTeGer*4 IOLVL,IGOLD
  378. C    COMMON/IOLVL/IOLVL
  379. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  380. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  381.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  382.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  383.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  384. C ***<<< RDD COMMON END >>>***
  385. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  386. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  387.     REAL*8 XAC,XVBLS(1,1)
  388.     REAL*8 TAC,UAC,VAC
  389.     INTEGER*4 JVBLS(2,1,1)
  390.     EQUIVALENCE(XAC,AVBLS(1,27))
  391.     EQUIVALENCE(TAC,AVBLS(1,20))
  392.     EQUIVALENCE(UAC,AVBLS(1,21))
  393.     EQUIVALENCE(VAC,AVBLS(1,22))
  394.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  395.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  396.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  397. C    CHARACTER*1 FORM(4)
  398.     CHARACTER*1 CELNAM(5)
  399.     character*18 annam
  400.     CHARACTER*1 annams(18)
  401.     equivalence(annam(1:1),annams(1))
  402.     CHARACTER*5 CELNM
  403.     CHARACTER*5 CELRW
  404.     EQUIVALENCE(CELNM(1:1),CELRW(1:1),CELNAM(1))
  405. C    EQUIVALENCE(FORM(1),CELNAM(1))
  406. C    EQUIVALENCE(CELRW,CELNAM(1))
  407. C ***<<< KLSTO COMMON START >>>***
  408.     InTeGer*4 DLFG
  409. C    COMMON/DLFG/DLFG
  410.     InTeGer*4 KDRW,KDCL
  411. C    COMMON/DOT/KDRW,KDCL
  412.     InTeGer*4 DTRENA
  413. C    COMMON/DTRCMN/DTRENA
  414.     REAL*8 EP,PV,FV
  415.     DIMENSION EP(20)
  416.     INTEGER*4 KIRR
  417. C    COMMON/ERNPER/EP,PV,FV,KIRR
  418.     InTeGer*4 LASTOP
  419. C    COMMON/ERROR/LASTOP
  420.     CHARACTER*1 FMTDAT(9,76)
  421. C    COMMON/FMTBFR/FMTDAT
  422.     CHARACTER*1 EDNAM(16)
  423. C    COMMON/EDNAM/EDNAM
  424.     InTeGer*4 MFID(2),MFMOD(2)
  425. C    COMMON/FRM/MFID,MFMOD
  426.     InTeGer*4 JMVFG,JMVOLD
  427. C    COMMON/FUBAR/JMVFG,JMVOLD
  428.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  429.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  430. C ***<<< KLSTO COMMON END >>>***
  431. CCC    CHARACTER*1 EDNAM(16)
  432. CCC    common/ednam/ednam
  433. c available parsing aid:
  434. c call varscn(line,ibgn,lend,lstchr,id1,id2,ivalid)
  435. c where line(ibgn... lend) is scanned. If variable found
  436. c ivalid=1 else ivalid=0. id1,id2 are dims in xvbls for
  437. c variable found if any. lstchr is last char found+1...
  438. C OTHER USEFUL ROUTINES IN THE SHEET:
  439. C GN(LAST,LEND,NUMBER,LINE)
  440. C  LOOKS FROM LINE(LAST) THRU LINE(LEND) FOR A NUMBER AND
  441. C  RETURNS ANY NUMBER IN "NUMBER" ARG. ASSUMES "LINE" IS A
  442. C  BYTE ARRAY. (NO INDICATION OF WHERE THE NUMBER WAS FOUND
  443. C  HOWEVER). THROWS OUT LEADING SPACES, TERMINATES ON A NON
  444. C  NUMERIC.
  445. C INDEX(LINE,CHAR)
  446. C  EXPECTS LINE TO BE NULL TERMINATED AND RETURNS EITHER
  447. C  THE SUBSCRIPT (COUNTING FROM 1) OF CHAR IN LINE OR THE
  448. C  MAX SUBSCRIPT IN LINE (I.E., WHERE IT HIT THE NULL TERMINATOR).
  449. C  NOTE THIS DIFFERS FROM THE "STANDARD" VERSION OF INDEX WHICH
  450. C  RETURNS 0 FOR "NOT FOUND" -- THIS VERSION RETURNS MAX LENGTH
  451. C  FOR "NOT FOUND". STOPS AT 512 BYTES HOWEVER...
  452. C  PARSING IS UP TO USER. NOTE VARSCN MAY BE CALLED TO PARSE
  453.     CHARACTER*1 CMDLIN(132)
  454. C    INTEGER*4 ISTTS
  455. C
  456. C 16 MUST BE LENGTH OF EDNAM IN BYTES
  457. C KEEP NAME "EDIT " IN DATA SO IT CAN BE BASHED IF NEEDED TO BE...
  458. C INSERT CODE FOR ADDING A LIB$SPAWN CALL HERE TO PASS COMMANDS TO
  459. C 75 IF THEY BEGIN WITH A $ CHARACTER.
  460.     IGOTIT=0
  461.     IF(CMDLIN(1).NE.'}'.AND.CMDLIN(1).NE.'$')GOTO 8990
  462. C
  463. CC HERE CALL EXECIT WITH THE COMMAND LINE AS AN ARGUMENT...
  464.     DO 1000 NN=1,80
  465. 1000    CMLN(NN)=CMDLIN(NN+1)
  466.     CMLN(79)=Char(13)
  467.     CMLN(80)=Char(0)
  468.     DO 1002 NN=1,77
  469.     N=78-NN
  470.     IF(ICHAR(CMLN(N)).GT.32)GOTO 1004
  471. 1002    CONTINUE
  472. C FINDING END OF REAL STRING THIS WAY
  473. 1004    CONTINUE
  474.     CMLN(N+1)=0
  475. c was =13, not =0 above...
  476. C ADD C.R., THEN NULL
  477.     CMLN(N+2)=0
  478.     CMLN(N+3)=0
  479. C INSERT LENGTH COUNT AS 1ST BYTE OF CMD LENGTH
  480. C PER DOS 2.0 MANUAL PG F-1
  481. ccc    CMLN2(1)=CHAR(N+3)
  482. ccc    CMLN2(2)='/'
  483. ccc    CMLN2(3)='C'
  484. ccc    CMLN2(4)=' '
  485. CC ! ADD C.R. AFTER LINE
  486. CC ABOVE, INSERT A CR AFTER CMD LINE
  487. C USE SYSTEM CALL INSTEAD OF OLDER CALL WHICH USES NOW-UNSUPPORTED
  488. C FORTRAN FEATURES IN MS-FORTRAN V3.3
  489.     call system(cmln2(5))
  490. c    N=SYSTEM(CMLN2(5))
  491. ccc    CALL EXECIT(CMLN2)
  492. C ASSUME WE NEED A REDRAW AFTER THE SPAWN FINISHES
  493. C EVENTUALLY FIGURE OUT HOW TO EXEC A ROUTINE THIS WAY, BUT JUST DUMMY OUT
  494. C  AT FIRST.
  495.     IF(CMDLIN(1).NE.'}')GOTO 2300
  496. C IMPLEMENT WAIT ON } FORM...
  497.     CALL UVT100(1,25,1)
  498.     CALL VWRT('Push Return key to return to sheet>',35)
  499.     READ(11,2400,END=2300,ERR=2300)IJUNK
  500. 2400    FORMAT(2A1)
  501. 2300    CONTINUE
  502.     ICODE=2
  503. C FLAG THE MAIN COMMAND PARSER WE HANDLED THE COMMAND
  504.     IGOTIT=1
  505. 8990    CONTINUE
  506.     IF(CMDLIN(1).NE.'F'.OR.
  507.      1     CMDLIN(2).NE.'I'.OR.
  508.      2     CMDLIN(3).NE.'L') GOTO 9000
  509.     IGOTIT=1
  510.     ICODE=3
  511.     CALL DTRCMD(CMDLIN(4))
  512. C ALLOW EXTRA COMMANDS OUT OF VAX VERSION...
  513. C
  514. 9000    CONTINUE
  515.     IF(CMDLIN(1).NE.'A'.OR.CMDLIN(2).NE.'N')GOTO 9200
  516. C ANNOTATE COMMAND SEEN
  517.     IGOTIT=1
  518.     ICODE=2
  519.     DO 9001 N=1,80
  520.     CMLN(N)=Char(32)
  521. 9001    CONTINUE
  522. C    CALL IN2AS(PROW,FORM)
  523.     CALL REFLEC(PCOL,PROW,IRX)
  524.     WRITE(CELRW(1:5),9002)IRX
  525. 9002    FORMAT(I5.5)
  526.     ICM=17
  527.     DO 9040 N=1,3
  528.     IXX=ICHAR(NMSH(N))
  529.     IF(IXX.GT.96)IXX=IXX-32
  530.     IF(IXX.LT.65.OR.IXX.GT.90)GOTO 9040
  531.     CMLN(ICM)=CHAR(IXX)
  532.     ICM=ICM+1
  533. 9040    CONTINUE
  534.     ICM=ICM-1
  535.     DO 9003 N=1,5
  536.     CMLN(N+ICM)=CELNAM(N)
  537. 9003    CONTINUE
  538.     CMLN(ICM+6)='.'
  539.     CMLN(ICM+7)='A'
  540.     CMLN(ICM+8)='N'
  541.     CMLN(ICM+9)='N'
  542.     CMLN(ICM+10)=' '
  543.     CMLN(80)=13
  544.     DO 9008 N=1,16
  545.     CMLN(N)=EDNAM(N)
  546. 9008    CONTINUE
  547. C NOW HAVE "EDIT name.ANN"
  548. c built... go fire it up for creation or modification of annotation...
  549.     DO 9150 N=17,ICM+9
  550.     IF(CMLN(N).EQ.' ')CMLN(N)='0'
  551. 9150    CONTINUE
  552.     DO 9162 NN=1,77
  553.     N=78-NN
  554.     IF(ICHAR(CMLN(N)).GT.32)GOTO 9164
  555. 9162    CONTINUE
  556. C FINDING END OF REAL STRING THIS WAY
  557. 9164    CONTINUE
  558.     CMLN(N+1)=Char(13)
  559. C ADD C.R., THEN NULL
  560.     CMLN(N+2)=Char(0)
  561.     CMLN(N+3)=Char(0)
  562.     N=SYSTEM(CMLN2(5))
  563.     GOTO 9990
  564. 9200    CONTINUE
  565.     IF(CMDLIN(1).NE.'?'.AND.(CMDLIN(1).NE.'Q'.OR.CMDLIN(2)
  566.      1  .NE.'U'.OR.CMDLIN(3).NE.'E')) GOTO 9300
  567. C QUERY COMMAND SEEN
  568.     IGOTIT=1
  569.     ICODE=2
  570.     DO 9237 N=1,18
  571. 9237    ANNAMS(N)=CHAR(32)
  572.     CALL REFLEC(PCOL,PROW,IRX)
  573.     WRITE(CELRW(1:5),9002)IRX
  574.     ICM=0
  575.     do 9238 n=1,18
  576.     annams(n)=char(32)
  577. 9238    continue
  578.     DO 9240 N=1,3
  579. C NOTE ANNOTATION NAMES ARE DIFFERENT HERE FROM VAX...
  580. C USE NAMnnnnn.ANN WHERE nnnnn IS CELL HASH AND "NAM" COMES
  581. C FROM 1ST 3 CHARS OF SHEET TITLE.
  582.     IXX=ICHAR(NMSH(N))
  583.     IF(IXX.GT.96)IXX=IXX-32
  584.     IF(IXX.LT.65.OR.IXX.GT.90)GOTO 9240
  585.     ICM=ICM+1
  586.     ANNAMS(ICM)=CHAR(IXX)
  587. 9240    CONTINUE
  588.     DO 9241 N=1,5
  589.     ANNAMS(ICM+N)=CELNAM(N)
  590. 9241    CONTINUE
  591.     ANNAMS(ICM+6)='.'
  592.     ANNAMS(ICM+7)='A'
  593.     ANNAMS(ICM+8)='N'
  594.     ANNAMS(ICM+9)='N'
  595.     DO 9250 N=1,18
  596.     IF(ANNAMS(N).EQ.' ')ANNAMS(N)='0'
  597. 9250    CONTINUE
  598.     ANNAMS(ICM+10)=' '
  599. C GO TO 9210 IF NO FILE
  600.     INQUIRE (FILE=ANNAM,EXIST=LEXIST)
  601.     IF(.NOT.LEXIST)GOTO 9210
  602.     OPEN(UNIT=2,FILE=ANNAM,ACCESS='SEQUENTIAL',STATUS='OLD')
  603.     DO 9030 N=1,20
  604.     READ(2,9031,END=9032,ERR=9032)WRK
  605. 9031    FORMAT(128A1)
  606.     CALL UVT100(1,N+2,1)
  607.     CALL UVT100(12,2,0)
  608.     call swrt(wrk,79)
  609. c    WRITE(6,9035)WRK
  610. 9035    FORMAT(128A1)
  611. 9030    CONTINUE
  612. 9032    CONTINUE
  613. C THIS DISPLAYS ALL THE ANNOTATION WE HAVE...
  614.     CLOSE(UNIT=2)
  615.     CALL UVT100(1,LLCMD,1)
  616.     CALL UVT100(12,2,0)
  617.     CALL VWRT('Push Return key to return to sheet>',35)
  618.     READ(11,2400,END=9990,ERR=9990)IJUNK
  619.     GOTO 9990
  620. 9210    CONTINUE
  621.     ICODE=3
  622.     CALL UVT100(1,LLDSP,1)
  623.     call uvt100(12,2,0)
  624.     CALL SWRT('No Annotation found on thic cell.',33)
  625. c    WRITE(6,9211)
  626. c9211    FORMAT(' No annotation found on this cell.')
  627. 9300    CONTINUE
  628. C
  629. 9990    CONTINUE
  630.     RETURN
  631.     END
  632. c -h- usrfct.for    Fri Aug 22 13:36:30 1986    
  633. C USER FUNCTION ROUTINE
  634. C GENERATES PARSING AND EXECUTION OF ROUTINE CALLS OF FORM
  635. C  *U FNAME (ARGUMENTS)
  636. C WHERE LINE (80 BYTES) CONTAINS COMMAND LINE AND ALL
  637. C ARGUMENTS MAY BE PARSED.
  638. C CALLED FROM CMND
  639. C
  640. C VAX VERSION: MOST MATRIX ROUTINES AVAILABLE
  641. C BUT ASSUMES SUBSTANTIAL SPACE AVAILABLE.
  642. C
  643. c available parsing aid:
  644. c call varscn(line,ibgn,lend,lstchr,id1,id2,ivalid)
  645. c where line(ibgn... lend) is scanned. If variable found
  646. c ivalid=1 else ivalid=0. id1,id2 are dims in xvbls for
  647. c variable found if any. lstchr is last char found+1...
  648. C OTHER USEFUL ROUTINES IN THE SHEET:
  649. C GN(LAST,LEND,NUMBER,LINE)
  650. C  LOOKS FROM LINE(LAST) THRU LINE(LEND) FOR A NUMBER AND
  651. C  RETURNS ANY NUMBER IN "NUMBER" ARG. ASSUMES "LINE" IS A
  652. C  BYTE ARRAY. (NO INDICATION OF WHERE THE NUMBER WAS FOUND
  653. C  HOWEVER). THROWS OUT LEADING SPACES, TERMINATES ON A NON
  654. C  NUMERIC.
  655. C INDEX(LINE,CHAR)
  656. C  EXPECTS LINE TO BE NULL TERMINATED AND RETURNS EITHER
  657. C  THE SUBSCRIPT (COUNTING FROM 1) OF CHAR IN LINE OR THE
  658. C  MAX SUBSCRIPT IN LINE (I.E., WHERE IT HIT THE NULL TERMINATOR).
  659. C  NOTE THIS DIFFERS FROM THE "STANDARD" VERSION OF INDEX WHICH
  660. C  RETURNS 0 FOR "NOT FOUND" -- THIS VERSION RETURNS MAX LENGTH
  661. C  FOR "NOT FOUND". STOPS AT 512 BYTES HOWEVER...
  662. C  PARSING IS UP TO USER. NOTE VARSCN MAY BE CALLED TO PARSE
  663. C VARIABLE NAMES. SUPPLIED VERSION CALLS IDATE WHICH RETURNS
  664. C SYSTEM DATE IN RSX OR VMS AS INTEGER DAY, MONTH, AND YEAR.
  665. C  THIS RETURNS HERE IN AC T, U, AND V
  666. C
  667.     SUBROUTINE USRFCT(LINE,RETCD,WRK2)
  668.     CHARACTER*1 LINE(80)
  669.     INTEGER RETCD
  670.     CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
  671.     CHARACTER*1 WRK2(128)
  672.     InTeGer*4 TYPE(1,1),VLEN(9)
  673.     EXTERNAL INDX
  674.     REAL*8 XAC,XVBLS(1,1)
  675.     REAL*8 TAC,UAC,VAC,WAC,YAC
  676.     REAL*8 TMP,XXXX
  677.     INTEGER*4 JVBLS(2,1,1)
  678.     EQUIVALENCE(WAC,AVBLS(1,23)),(YAC,AVBLS(1,25))
  679.     EQUIVALENCE(XAC,AVBLS(1,27))
  680.     EQUIVALENCE(TAC,AVBLS(1,20))
  681.     EQUIVALENCE(UAC,AVBLS(1,21))
  682.     EQUIVALENCE(VAC,AVBLS(1,22))
  683.     EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
  684.     EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
  685.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  686. CCC    InTeGer*4 XTNCNT,XTCFG,IPSET
  687. CCC    CHARACTER*1 XTNCMD(80)
  688. CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  689. C ***<<<< RDD COMMON START >>>***
  690.     InTeGer*4 RRWACT,RCLACT
  691. C    COMMON/RCLACT/RRWACT,RCLACT
  692.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  693.      1  IDOL7,IDOL8
  694. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  695. C     1  IDOL7,IDOL8
  696.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  697. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  698.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  699. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  700. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  701. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  702.     InTeGer*4 KLVL
  703. C    COMMON/KLVL/KLVL
  704.     InTeGer*4 IOLVL,IGOLD
  705. C    COMMON/IOLVL/IOLVL
  706. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  707. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  708.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  709.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  710.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  711. C ***<<< RDD COMMON END >>>***
  712. CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  713. CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
  714. CCC    InTeGer*4 RRWACT,RCLACT
  715. CCC    COMMON/RCLACT/RRWACT,RCLACT
  716. C ***<<< XVXTCD COMMON START >>>***
  717.     CHARACTER*1 OARRY(100)
  718.     InTeGer*4 OSWIT,OCNTR
  719. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  720. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  721.     InTeGer*4 IPS1,IPS2,MODFLG
  722. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  723.        InTeGer*4 XTCFG,IPSET,XTNCNT
  724.        CHARACTER*1 XTNCMD(80)
  725. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  726. C VARY FLAG ITERATION COUNT
  727.     INTEGER KALKIT
  728. C    COMMON/VARYIT/KALKIT
  729.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  730.     InTeGer*4 RCMODE,IRCE1,IRCE2
  731.  
  732. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  733. C     1  IRCE2
  734. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  735. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  736. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  737. C RCFGX ON.
  738. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  739. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  740. C  AND VM INHIBITS. (SETS TO 1).
  741.     INTEGER*4 FH
  742. C FILE HANDLE FOR CONSOLE I/O (RAW)
  743. C    COMMON/CONSFH/FH
  744.     CHARACTER*1 ARGSTR(52,4)
  745. C    COMMON/ARGSTR/ARGSTR
  746.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  747.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  748.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  749.      3  IRCE2,FH,ARGSTR
  750. C ***<<< XVXTCD COMMON END >>>***
  751. CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
  752. CCC    COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  753. C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
  754. C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
  755. C (IMPLEMENT FOR VAX ONLY)
  756. CCC    INTEGER KALKIT
  757. CCC    COMMON/VARYIT/KALKIT
  758. C ARGUMENTS COME IN IN ARGUMENTS IN LINE
  759. C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
  760. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  761. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  762.     DIMENSION NRDSP(20,75),NCDSP(20,75)
  763.     COMMON/D2R/NRDSP,NCDSP
  764.     CHARACTER*1 FNAMS(6,23)
  765. C FNAMS IS NAME OF FUNCTION CALLED.
  766.     DATA FNAMS /'I','D','A','T','E','0',
  767.      1  'M','T','X','E','Q','0',
  768.      2  'M','O','V','E','V','0',
  769.      3  'M','D','E','T','0','0',
  770.      4  'M','P','R','O','D','0',
  771.      5  'M','A','D','D','V','0','M','S','U','B','V','0',
  772.      7  'M','M','P','Y','T','0','M','M','P','Y','C','0',
  773.      9  'V','A','R','Y','0','0','X','Q','T','C','M','0',
  774.      2  'S','T','R','V','L','0','H','E','R','E','0','0',
  775.      4  'Y','R','M','O','D','0','J','D','A','T','E','0',
  776.      6  'J','T','O','C','H','0','D','A','T','E','0','0',
  777.      1  'W','K','D','Y','S','0','W','K','D','I','N','0',
  778.      2  'F','F','T','F','W','0','F','F','T','R','V','0',
  779.      3  'L','I','N','E','F','0','D','B','0','0','0','0'/
  780. C NULL TERMINATE ANY NAMES (ALLOWS 5 CHARACTERS)
  781. C START LOOKING PAST THE *U
  782. C  GET FUNCTION NAME AND GO TO PROCESS EACH FUNCTION SEPARATELY
  783. C GET NONBLANK CHAR FOR FUNCTION NAME START
  784. C NO-OP THE XQTCM FUNCTION FOR PDP11-OVERLAIN VERSIONS BY ZAPPING
  785. C THE NAME SO IT CAN'T EVER BE CALLED.
  786.     K=3
  787. 30    IF(LINE(K).NE.' ')GOTO 40
  788.     K=K+1
  789.     IF(K.LT.60)GOTO 30
  790. 40    CONTINUE
  791. C UNCOMMENT THE DO 100 STMT IF DIM 2 OF FNAMS > 1
  792.     N=1
  793. C **** BE SURE THE 2ND BOUND ON N IS THE SAME AS THE DIMENSION OF
  794. C ****  FNAMS   **************************
  795. C    DO 7771 N=1,17
  796. C    DO 7771 NN=1,6
  797. C    IF(FNAMS(NN,N).EQ.'0')FNAMS(NN,N)=0
  798. C7771    CONTINUE
  799.     DO 100 N=1,23
  800.     KF=N
  801.     DO 110 NN=1,6
  802. C CHECK FOR '0' IN FUNCTION NAME AND SKIP ON THAT... 48 IS ASCII /0/
  803.     IF(LINE(K+NN-1).NE.FNAMS(NN,N).AND.ICHAR(FNAMS(NN,N)).NE.48)
  804.      1  GOTO 100
  805. 110    CONTINUE
  806.     GOTO 200
  807. 100    CONTINUE
  808. C UNRECOGNIZED FUNCTION... IGNORE
  809. 300    RETCD=3
  810.     RETURN
  811. 200    CONTINUE
  812. C NOW HAVE FOUND FUNCTION IDENTIFIED BY KF. CALL IT AND ALLOW TO WORK
  813.     GOTO (1100,1200,1300,1400,1500,1600,1700,1800,
  814.      1  1900,2000,2100,2200,2300,2400,2500,2600,2700,
  815.      2  2900,3000,3100,3200,3300,3400),KF
  816.     GOTO 300
  817. 1100    CONTINUE
  818. C IDATE FUNCTION
  819. C RETURNS MONTH, DAY, YEAR IN AC'S T,U,V
  820. C RETURN 4/1/85 (APRIL FOOLS DAY)
  821. C    IDA=1
  822. C    IMO=4
  823. C    IYR=85
  824. C    CALL IDATE(IMO,IDA,IYR)
  825.     CALL DATE(IYR,IMO,IDA)
  826. C CALL supplied GET-DATE FUNCTION AND HOPE IT'S OK
  827.     TAC=IMO
  828.     UAC=IDA
  829.     IYR=IYR-1900
  830.     VAC=IYR
  831. C RETURN A FLOATING VALUE OF DATE FORM AS YYMMDD SO IT CAN BE
  832. C USED FOR SORTING AND SIMILAR APPLICATIONS. COULD BE USED ALSO
  833. C FOR INTERVALS IF A JULIAN DATE WERE RETURNED, BUT THIS WILL DO
  834. C FOR COMPARISONS AND ORDERING.
  835.     XAC=JULMDY(IYR,IMO,IDA)
  836. C    XAC=VAC*10000.+TAC*100.+UAC
  837.     RETURN
  838. 1200    CONTINUE
  839. C MATRIX EQUATION. NOTE WE MUST NOW START SCAN FOR ARGUMENTS...
  840. C K+5 IS START OF ARG LIST. START AT K+6 TO ALLOW ( TO BE THERE...
  841. C FORMAT DESIRED:
  842. C  *U MTXEQ(A1:A2,X1:X2,B1:B2) GENERATING SOLUTION MATRIX X1:X2
  843. C  FROM MATRICES A,B AND SOLVING EQUATION AX=B WHERE A IS AN N BY
  844. C  N SQUARE MATRIX, AND X AND B ARE N BY M MATRICES.
  845.     RETCD=1
  846. C COLLECT ARGUMENTS. NOTE THAT VARSCN AND GN TRASH POINTERS PASSED
  847. C TO THEM IN IBGN, LEND, SO MAKE UP EVERY TIME. USE VARSCN TO
  848. C COLLECT POINTERS TO THE SHEET ARRAY FIRST OFF COMMAND LINE,
  849. C THEN PROCESS IN OUR MAGICAL MYSTICAL ROUTINE...
  850.     IBGN=K+6
  851.     LEND=IBGN+20
  852. C GET LOCATIONS OF MATRICES A, X, AND B (FOR AX=B EQN)
  853. C A MUST BER N BY N, SQUARE. X,B ARE N BY M.
  854.     CALL PMTX2(RETCD,3,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  855.      1   IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  856.     N=IABS(ID1B-ID1A)+1
  857. C CHECK THAT MATRIX A IS SQUARE
  858.     IF(N.NE.(IABS(ID2B-ID2A)+1))GOTO 300
  859. C CHECK THAT MATRIX X AND B HAVE THE SAME DIMENSIONS
  860.     IF((IDYA-IDXA).NE.(IDCA-IDBA))GOTO 300
  861.     IF((IDYB-IDXB).NE.(IDCB-IDBB))GOTO 300
  862.     M=IABS(IDYA-IDXA)+1
  863. C CHECK THAT THE X AND B MATRIX DIMENSIONS ARE N BY M
  864. C WHERE THE N IS THE SAME AS FOR THE A MATRIX
  865.     NN=IABS(IDYB-IDXB)+1
  866.     IF(NN.NE.N)GOTO 300
  867. C NOW HAVE DIMENSIONS FOR ALL THIS STUFF...
  868. C SINCE MTXEQU TRASHES ITS' B MATRIX, COPY IT INTO X MATRIX
  869. C AND THEN CALL...
  870.     DO 1210 NN=IDBA,IDCA
  871.     DO 1210 MM=IDBB,IDCB
  872.     CALL XVBLGT(NN,MM,XVBLS(1,1))
  873.     CALL XVBLST(NN-IDBA+IDXA,MM-IDBB+IDXB,XVBLS(1,1))
  874. C    XVBLS(NN-IDBA+IDXA,MM-IDBB+IDXB)=XVBLS(NN,MM)
  875. 1210    CONTINUE
  876. C NOW ALL THE ARGUMENTS ARE SET UP... GO DO THE WORK.
  877. C CALL UTILITY ROUTINE, THEN DONE...
  878.     CALL MTXEQU(ID1A,ID2A,IDXA,IDXB,N,M,XAC)
  879.     RETURN
  880. 1300    CONTINUE
  881. C MOVEV  MTX1 MTX2  MOVE MTX1 VALUES TO MTX2
  882.     RETCD=1
  883.     IBGN=K+6
  884.     CALL PMTX2(RETCD,2,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,IR2T,IC2T,
  885.      1  IR2B,IC2B,KK,KK,KK,KK)
  886. C CHECK FOR SAME SIZE MATRICES
  887.     IF((IC1T-IC1B).NE.(IC2T-IC2B))GOTO 300
  888.     IF((IR1T-IR1B).NE.(IR2T-IR2B))GOTO 300
  889. C DO THE COPY HERE (EASIER THAN CALLING SOMETHING...)
  890.     DO 1301 NN=IR1T,IR1B
  891.     DO 1301 MM=IC1T,IC1B
  892.     CALL XVBLGT(NN,MM,XVBLS(1,1))
  893.     CALL XVBLST(NN-IR1T+IR2T,MM-IC1T+IC2T,XVBLS(1,1))
  894. C    XVBLS(NN-IR1T+IR2T,MM-IC1T+IC2T)=XVBLS(NN,MM)
  895. 1301    CONTINUE
  896.     RETURN
  897. 1400    CONTINUE
  898. C MDET  - DETERMINANT OF SQUARE MATRIX
  899. C  1 ARGUMENT, VIZ., MATRIX COORDS
  900.     RETCD=1
  901. C ACCOUNT FOR "MDET" BEING 4 CHARS NOT 5
  902.     IBGN=K+5
  903.     CALL PMTX2(RETCD,1,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,
  904.      1  IV,IV,IV,IV,IV,IV,IV,IV)
  905. C CALL A DETERMINANT ROUTINE TO DO THE WORK
  906. C NOTE IT CHECKS FOR SQUARE MATRIX INTERNALLY AND RETURNS 0 IF NOT
  907. C SQUARE...
  908.     CALL MDET(XVBLS,IR1T,IC1T,IR1B,IC1B,XAC)
  909.     RETURN
  910. 1500    CONTINUE
  911. C MPROD A,B,C  C=A*B MATRIX WISE
  912.     IBGN=K+6
  913.     RETCD=1
  914.     IMXX=3
  915.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  916.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  917. C A=N BY M
  918. C B=M BY L
  919. C C=N BY L
  920.     N=1+ID1B-ID1A
  921.     M=1+ID2B-ID2A
  922. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  923.     L=1+IDYA-IDXA
  924. C    IF(N.NE.(1+IDCB-IDBB))GOTO 300
  925. C    IF(L.NE.(1+IDCA-IDBA))GOTO 300
  926. C DIMENSIONS LOOK OK NOW SO DO THE WORK
  927. C USE SLIGHTLY MODIFIED GMPRD
  928.     CALL GMPRD(ID1A,ID2A,IDXA,IDXB,
  929.      1  IDBA,IDBB,N,M,L)
  930.     RETURN
  931. 1600    CONTINUE
  932. C MADDV A,B,C  C=A+B
  933.     IMXX=3
  934.     IBGN=K+6
  935.     RETCD=1
  936.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  937.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  938.     N=1+ID1B-ID1A
  939.     M=1+ID2B-ID2A
  940. C    IF(N.NE.(1+IDYA-IDXA))GOTO 300
  941. C    IF(N.NE.(1+IDCA-IDBA))GOTO 300
  942. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  943. C    IF(M.NE.(1+IDCB-IDBB))GOTO 300
  944. C USE MODIFIED GMADD
  945.     CALL GMADD(ID1A,ID2A,IDXA,IDXB,
  946.      1  IDBA,IDBB,M,N)
  947.     RETURN
  948. 1700    CONTINUE
  949. C MSUBV A,B,C  C=A-B
  950.     IMXX=3
  951.     IBGN=K+6
  952.     RETCD=1
  953.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  954.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  955.     N=1+ID1B-ID1A
  956.     M=1+ID2B-ID2A
  957. C    IF(N.NE.(1+IDYA-IDXA))GOTO 300
  958. C    IF(N.NE.(1+IDCA-IDBA))GOTO 300
  959. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  960. C    IF(M.NE.(1+IDCB-IDBB))GOTO 300
  961.     CALL GMSUB(ID1A,ID2A,IDXA,IDXB,
  962.      1  IDBA,IDBB,M,N)
  963.     RETURN
  964. 1800    CONTINUE
  965. C MMPYT A,B,C  C=AT*B
  966. C GET 3 MATRICES
  967.     IMXX=3
  968.     IBGN=K+6
  969.     RETCD=1
  970.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  971.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  972. C TRANSPOSE DIMENSIONS OF A...
  973.     M=1+ID1B-ID1A
  974.     N=1+ID2B-ID2A
  975. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  976.     L=1+IDYA-IDXA
  977. C    IF(N.NE.(1+IDCB-IDBB))GOTO 300
  978. C    IF(L.NE.(1+IDCA-IDBA))GOTO 300
  979.     CALL GTPRD(ID1A,ID2A,IDXA,IDXB,
  980.      1  IDBA,IDBB,N,M,L)
  981.     RETURN
  982. 1900    CONTINUE
  983. C MMPYC A,B,K  B=A*K (K=CONSTANT)
  984. C FOR MPY BY CONSTANT WE GET MATRICES IN ORDER A,C, THEN AC WITH CONST
  985. C IN IT LAST...
  986.     IBGN=K+6
  987.     RETCD=1
  988.     IMXX=2
  989.     CALL PMTX2(RETCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
  990.      1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
  991.     IF(LINE(IBGN-1).NE.',')GOTO 300
  992.     LEND=IBGN+20
  993.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,IDCA,IDCB,IVALID)
  994.     IF(IVALID.EQ.0)GOTO 300
  995. C NOW HAVE EVERYTHING OF ARGS... CHECK DIMENSIONS OF MATRICES....
  996.     N=1+ID1B-ID1A
  997.     M=1+ID2B-ID2A
  998. C    IF(N.NE.(1+IDYA-IDXA))GOTO 300
  999. C    IF(M.NE.(1+IDYB-IDXB))GOTO 300
  1000.     CALL XVBLGT(IDCA,IDCB,XXXX)
  1001.     DO 1901 NN=ID1A,ID1B
  1002.     DO 1901 MM=ID2A,ID2B
  1003.     CALL XVBLGT(NN,MM,XVBLS(1,1))
  1004.     XVBLS(1,1)=XVBLS(1,1)*XXXX
  1005.     CALL XVBLST(NN-ID1A+IDXA,MM-ID2A+IDXB,XVBLS(1,1))
  1006. C    XVBLS(NN-ID1A+IDXA,MM-ID2A+IDXB)=XVBLS(NN,MM)
  1007. C     1    *XVBLS(IDCA,IDCB)
  1008. 1901    CONTINUE
  1009.     RETURN
  1010. C *U VARY X,A,W,I,P;Q;R;S;T
  1011. C  REPEATEDLY COMPUTE SHEET FOR I ITERATIONS (DEFAULTS TO 1
  1012. C  IF NONE GIVEN) AND VARY AC P,Q,R,S, T (POSITIONAL...WHATEVER
  1013. C  IS NAMED) UNTIL CONDITION THAT AC X (WHATEVER IS NAMED THERE)
  1014. C  IS MADE EQUAL TO AC A AS CLOSELY AS POSSIBLE. DOES MULTI-DIMENSIONAL
  1015. C  STEPPING SEARCH SAVING AC'S AND MODIFYING. ACTUALLY WILL HANDLE ANY
  1016. C  CELL. UP TO 8 DIMENSIONS PERMITTED (ARBITRARY LIMIT).
  1017. C  NOTE THAT RECALCULATE SPECIAL VARY FLAG WILL BE SET HERE IF
  1018. C  VARYING MORE THAN ONCE...
  1019. C  WILL VARY ONE OF THE AC'S IN THE LIST P,Q,R,S,T... BY INITIAL
  1020. C  FRACTION W (AN ARBITRARY "STEP SIZE" FRACTION) AND COMPUTE THE
  1021. C  GRADIENT OF (X-A) WRT THAT AC, THEN WILL REPLACE ALL AC'S AND
  1022. C  VARY THAT AC BY W * THE GRADIENT, MEANING THAT AS THE GRADIENT
  1023. C  DECREASES, THE VARIANCE DOES ALSO. LAST GRADIENTS ARE SAVED AND
  1024. C  USED AS INITIAL VARIANCES, SO THAT THE W FRACTION IS AN INITIAL
  1025. C  GUESS. HOWEVER IT ALSO IS A LIMIT SO NO STEP VARIES AN AC BY
  1026. C  MORE FRACTIONALLY THAN W.
  1027. C   ONCE THIS IS DONE ANOTHER ONE OF THE P,Q,R,S,T,... LIST IS
  1028. C  CHOSEN CIRCULARLY AND THE PROCESS REPEATS. THIS MAY CONTINUE
  1029. C  INDEFINITELY TO LOOK FOR CONVERGENCE.
  1030. C   NOTE THAT X AND A MAY BE ANY CELL AND NEED NOT BE ACCUMULATORS.
  1031. C  HOWEVER ALL OTHER CELLS TO VARY MUST BE AC'S AND MUST BE THE
  1032. C  INDEPENDENT VARIABLES. CALCULATIONS ELSEWHERE ON THE SHEET
  1033. C  (PERHAPS LATER IN THE SAME CELL...)MUST ESTABLISH DEPENDENT
  1034. C  VARIABLES OR BOUNDARY OR NORMALIZATION CONDITIONS.
  1035. 2000    CONTINUE
  1036.     RETCD=1
  1037. C SPLIT OFF THESE FUNCTIONS INTO A COMMON SUBROUTINE
  1038.     CALL VVARY(LINE,RETCD,K)
  1039.     RETURN
  1040. 2100    CONTINUE
  1041. C EXECUTE COMMAND. FILL IN COMMAND FROM GIVEN FUNCTION AND
  1042. C CALL XQTCMD TO DO IT. SETS UP NECESSARY VARIABLES FIRST.
  1043. C ASSUME THE COMMAND LINE MUST BE ALONE ON LINE AFTER THIS CALL...
  1044.     KK=1
  1045.     KKK=K+6
  1046.     DO 2101 NN=KKK,80
  1047.     XTNCMD(KK)=LINE(NN)
  1048.     IF(ICHAR(XTNCMD(KK)).LE.0)GOTO 2102
  1049.     KK=KK+1
  1050. 2101    CONTINUE
  1051. 2102    CONTINUE
  1052.     XTNCMD(KK+1)=0
  1053.     XTNCMD(KK+2)=0
  1054.     XTNCNT=KK
  1055.     XTCFG=1
  1056.     IPSET=1
  1057.     CALL XQTCMD(ICODE)
  1058.     RETURN
  1059. 2200    CONTINUE
  1060. C RETURN PACKED FORMULA STRING TO EXTRACT UP TO 8 CHARS OF
  1061. C FORMULA.
  1062. C START AT K+6
  1063.     XAC=0.
  1064.     IBGN=K+6
  1065.     IEND=IBGN+20
  1066.     CALL VARSCN(LINE,IBGN,IEND,LSTC,I1,I2,IVLD)
  1067.     IF(IVLD.LE.0)RETURN
  1068. C GET START, LENGTH NOW IN FORMULA...
  1069.     IBGN=LSTC+1
  1070.     IEND=IBGN+20
  1071.     CALL GN(IBGN,IEND,ISTART,LINE)
  1072.     IBGN=INDX(LINE,ICHAR(';'))
  1073. C LOOK FOR ';' CHAR AS START OF 2ND NUMBER
  1074.     IF(IBGN.GT.50.OR.ISTART.LE.0.OR.ISTART.GT.80)RETURN
  1075. C BUMP IBGN PAST THE ; CHAR
  1076.     IBGN=IBGN+1
  1077.     IEND=80
  1078.     CALL GN(IBGN,IEND,ILN,LINE)
  1079.     ILN=MIN0(ILN,8)
  1080.     IF(ILN.LE.0)RETURN
  1081. C READ IN FORMULA INTO WRK ARRAY
  1082. C    IRX=(I2-1)*60+I1
  1083.     CALL REFLEC(I2,I1,IRX)
  1084.     CALL WRKFIL(IRX,WRK2,0)
  1085.     CALL CE2A(WRK2,WRK)
  1086.     KZ=0
  1087.     DO 991 NN=1,ILN
  1088.     K=ICHAR(WRK(ISTART+NN-1))
  1089. C    K=K.AND.127
  1090.     IF(K.EQ.0)KZ=1
  1091.     IF(KZ.EQ.1)K=0
  1092. C STOP THE ENCODE ON SEEING ANY NULLS
  1093.     TMP=K
  1094.     XAC=XAC*128.D0+TMP
  1095. 991    CONTINUE
  1096. C XAC RETURNS WITH ENCODED VALUE.
  1097.     RETURN
  1098. 2300    CONTINUE
  1099. C RETURN PRESENT LOCATION IN THE MATRIX.
  1100.     TAC=PROW
  1101.     UAC=PCOL
  1102.     XAC=(PCOL-1)*60+PROW
  1103.     VAC=4*FORMFG+2*RCFGX+RCONE
  1104. C    VAC=(DROW-1)*20+DCOL
  1105. C RESULT IN % IS PHYS SHEET HASHCODE
  1106. C RESULT IN V ACCUMULATOR IS DISPLAY SHEET LOC HASHCODE
  1107. C T AND U ACCUMULATORS GET PHYS COL, ROW OFFSET.
  1108.     WAC=RRWACT
  1109.     YAC=RCLACT
  1110. C W AND Y GET LIMITS CURRENTLY USED
  1111.     RETURN
  1112. 2400    CONTINUE
  1113. C YRMOD
  1114.     RETCD=1
  1115.     IBGN=K+6
  1116.     LEND=IBGN+20
  1117.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  1118.     IF(IVALID.EQ.0)GOTO 9300
  1119.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  1120.     IBGN=LSTCHR+1
  1121.     LEND=IBGN+20
  1122.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  1123.     IF(IVALID.EQ.0)GOTO 9300
  1124.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  1125.     IBGN=LSTCHR+1
  1126.     LEND=IBGN+20
  1127.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1C,ID2C,IVALID)
  1128.     IF(IVALID.EQ.0)GOTO 9300
  1129. C
  1130. C V1, V2, V3 ARE YR, MONTH, DAY FOR RETURN OF JULIAN DATE
  1131. C
  1132.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  1133.     IYR=XVBLS(1,1)
  1134.     CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  1135.     IMO=XVBLS(1,1)
  1136.     CALL XVBLGT(ID1C,ID2C,XVBLS(1,1))
  1137.     IDA=XVBLS(1,1)
  1138. C RETURN JULIAN DATE FROM Y, M, D GIVEN
  1139.     XAC=JULMDY(IYR,IMO,IDA)
  1140.     RETURN
  1141. 2500    CONTINUE
  1142. C JDATE
  1143.     RETCD=1
  1144.     IBGN=K+6
  1145.     LEND=IBGN+20
  1146. C GET V1 WHICH HAS VARIABLE WITH THE STRING IN IT
  1147.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  1148.     IF(IVALID.EQ.0)GOTO 9300
  1149. C RETURN JULIAN DATE NOW AFTER FETCHING FORMULA.
  1150. C    IRX=(ID2A-1)*60+ID1A
  1151.     CALL REFLEC(ID2A,ID1A,IRX)
  1152.     CALL WRKFIL(IRX,WRK,0)
  1153.     XAC=JULIAN(WRK)
  1154.     RETURN
  1155. 2600    CONTINUE
  1156. C JTOCH
  1157.     RETCD=1
  1158.     IBGN=K+6
  1159.     LEND=IBGN+20
  1160. C V1 = JULIAN DATE
  1161. C V2 IS WHERE TO STORE ASCII DATE STRING AS FORMULA.
  1162.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  1163.     IF(IVALID.EQ.0)GOTO 9300
  1164.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  1165.     IBGN=LSTCHR+1
  1166.     LEND=IBGN+20
  1167.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  1168.     IF(IVALID.EQ.0)GOTO 9300
  1169.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  1170.     IJUL=XVBLS(1,1)
  1171. C    IRX=(ID2B-1)*60+ID1B
  1172.     CALL REFLEC(ID2B,ID1B,IRX)
  1173.     CALL WRKFIL(IRX,WRK,0)
  1174.     DO 2502 N=1,110
  1175. 2502    WRK(N)=0
  1176.     CALL JULASC(IJUL,WRK,IYR,IMO,IDA)
  1177.     CALL WRKFIL(IRX,WRK,1)
  1178. C WRITE THE FORMULA BACK OUT
  1179.     TAC=IMO
  1180.     UAC=IDA
  1181.     VAC=IYR
  1182. C RETURN T,U,V AS M,D,Y ALSO
  1183.     RETURN
  1184. 2700    CONTINUE
  1185. C DATE
  1186.     RETCD=1
  1187.     IBGN=K+5
  1188.     LEND=IBGN+20
  1189.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  1190.     IF(IVALID.EQ.0)GOTO 9300
  1191.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  1192.     IBGN=LSTCHR+1
  1193.     LEND=IBGN+20
  1194.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  1195.     IF(IVALID.EQ.0)GOTO 9300
  1196.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  1197.     IBGN=LSTCHR+1
  1198.     LEND=IBGN+20
  1199.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1C,ID2C,IVALID)
  1200.     IF(IVALID.EQ.0)GOTO 9300
  1201.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  1202.     IBGN=LSTCHR+1
  1203.     LEND=IBGN+20
  1204.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1D,ID2D,IVALID)
  1205.     IF(IVALID.EQ.0)GOTO 9300
  1206.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  1207.     IYR=XVBLS(1,1)
  1208.     CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  1209.     IMO=XVBLS(1,1)
  1210.     CALL XVBLGT(ID1C,ID2C,XVBLS(1,1))
  1211.     IDA=XVBLS(1,1)
  1212. C    IRX=(ID2D-1)*60+ID1D
  1213.     CALL REFLEC(ID2D,ID1D,IRX)
  1214.     CALL WRKFIL(IRX,WRK,0)
  1215.     DO 2702 N=1,110
  1216. 2702    WRK(N)=0
  1217.     IJUL=JULMDY(IYR,IMO,IDA)
  1218.     CALL JULASC(IJUL,WRK,IYR,IMO,IDA)
  1219.     CALL WRKFIL(IRX,WRK,1)
  1220.     GOTO 9300
  1221. 2900    CONTINUE
  1222.     RETCD=1
  1223. C WKDYS - GIVE WEEKDAYS (M-F) BETWEEN 2 JULIAN DATES THAT MUST
  1224. C BE IN CELLS.
  1225.     IBGN=K+6
  1226.     LEND=IBGN+20
  1227.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  1228.     IF(IVALID.EQ.0)GOTO 9300
  1229.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  1230.     IBGN=LSTCHR+1
  1231.     LEND=IBGN+20
  1232.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  1233.     IF(IVALID.EQ.0)GOTO 9300
  1234.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  1235.     IYR=XVBLS(1,1)
  1236.     CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  1237.     IMO=XVBLS(1,1)
  1238. C IYR HOLDS START JULIAN DATE, IMO HOLDS END ONE
  1239.     CALL WKDY(IYR,IMO,IDA)
  1240. C IDA = NUMBER WORK DAYS BETWEEN THE DATES
  1241.     XAC=IDA
  1242. C RETURN DAYS
  1243.     GOTO 9300
  1244. 3000    CONTINUE
  1245.     RETCD=1
  1246. C WKDIN - GIVEN A JULIAN DATE AND A NUMBER WORKDAYS, RETURN THE
  1247. C ENDING JULIAN DATE AFTER THAT NUMBER JULIAN DAYS.
  1248.     IBGN=K+6
  1249.     LEND=IBGN+20
  1250.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  1251.     IF(IVALID.EQ.0)GOTO 9300
  1252.     IF(LINE(LSTCHR).NE.',')GOTO 9300
  1253.     IBGN=LSTCHR+1
  1254.     LEND=IBGN+20
  1255.     CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  1256.     IF(IVALID.EQ.0)GOTO 9300
  1257.     CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
  1258.     IYR=XVBLS(1,1)
  1259.     CALL XVBLGT(ID1B,ID2B,XVBLS(1,1))
  1260.     IMO=XVBLS(1,1)
  1261. C IYR = START DATE, JULIAN. IMO = NUMBER DAYS. RETURN END DATE JULIAN.
  1262.     CALL WRKINT(IYR,IMO,IDA)
  1263. C IDA = RETURN JULIAN DATE
  1264.     XAC=IDA
  1265.     GOTO 9300
  1266. 3100    CONTINUE
  1267. C FFTFW
  1268.     ISI=1
  1269.     GOTO 3210
  1270. 3200    CONTINUE
  1271. C FFTRV
  1272.     ISI=-1
  1273. 3210    CONTINUE
  1274.     RETCD=1
  1275. C MERGED FFT CODE
  1276. C *U FFTFW V1:V2 DOES FFT OF RANGE GIVEN (1-DIM)
  1277. C DITTO FFTRV BUT ONE IS REVERSE AND ONE IS FORWARD FFT
  1278. C REAL*8 FFT ROUTINE USED.
  1279.     IBGN=K+6
  1280.     CALL PMTX2(RETCD,1,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,
  1281.      1  IV,IV,IV,IV,IV,IV,IV,IV)
  1282.     IC=0
  1283.     IR=1
  1284.     IF(IR1T.EQ.IR1B)GOTO 3220
  1285.     IC=1
  1286.     IR=0
  1287. 3220    CONTINUE
  1288.     KK=IABS(IR1T-IR1B)+1
  1289.     KKK=IABS(IC1T-IC1B)+1
  1290.     IV=MAX0(KK,KKK)
  1291. C IV = NO. POINTS.
  1292.     CALL FOUREA(IR1T,IC1T,IC,IR,IV,ISI)
  1293. C THAT'S ALL FOR FFT. REPLACES CELLS IN PLACE...
  1294.     GOTO 9300
  1295. 3300    CONTINUE
  1296. C LINEF
  1297. C *U LINEF VY1:VY2[,VX1:VX2]
  1298. C WHERE X COORDS CAN BE SKIPPED...
  1299.     IBGN=K+6
  1300.     RETCD=1
  1301. C JUST GET 2 MATRICES' VALUES. IF RETCD=3 ON RETURN, 2ND MATRIX MUST HAVE
  1302. C BEEN MISSING SO FLAG IT THAT WAY.
  1303.     CALL PMTX2(RETCD,2,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,IR2T,IC2T,
  1304.      1  IR2B,IC2B,KK,KK,KK,KK)
  1305.     IF(RETCD.NE.1)IR2T=-1
  1306.     RETCD=1
  1307.     KK=IABS(IR1T-IR1B)+1
  1308.     KKK=IABS(IC1T-IC1B)+1
  1309.     IV=MAX0(KK,KKK)
  1310.     KK=0
  1311.     IF(IR1T.EQ.IR1B)GOTO 3320
  1312.     KK=1
  1313. 3320    CONTINUE
  1314.     CALL LINFIT(IR2T,IC2T,KK,IR1T,IC1T,IV,TAC,UAC,XAC,WAC)
  1315. C RETURN A VALUE IN T, B VALUE IN U, AND DEL VALUE IN %.
  1316. C FOR Y = A + BX
  1317. C W AC RETURNS CORRELATION COEFFICIENT.
  1318.     GOTO 9300
  1319. 3400    CONTINUE
  1320. C *U DBxxxx FUNCTIONS PARSED EXTERNALLY
  1321. C (SAVES MUCH SPACE AND EASES MODIFICATION...)
  1322.     RETCD=1
  1323.     CALL DTRFCT(LINE(K+2),RETCD)
  1324. C    GOTO 9300
  1325. 9300    RETURN
  1326.     END
  1327. c -h- uvtgen.for    Fri Aug 22 13:36:30 1986    
  1328. C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
  1329. C ALL RIGHTS RESERVED
  1330. C
  1331. C    VT100 VIDEO DISPLAY COMMAND PROGRAM. CALLING SEQUENCE IS
  1332. C    CALL UVT100(CMD,N1,N2THE MANDS IN
  1333. C    THE PARAMETER LIST BELOW, AND N1 AND N2 ARE OPTIONAL PARAMETERS
  1334. C    DEPENDING UPON CMD. SEE THE UVT100 USER'S MANUAL FOR MORE DETAILS.
  1335. C
  1336. C
  1337. C BLACK AND WHITE SCREEN MODULE FOR ANSI TERMINALS
  1338. C ALSO COLOR SCREEN MODULE.
  1339. C COMMANDS 20 AND 21 SWITCH: 20 SETS B+W, 21 SETS COLOR MODE
  1340. C
  1341. C THIS VERSION MODIFIED FOR USE WITH PORTACALC.
  1342. C  ENTRIES NOT USED ARE DELETED, AND ALSO CODE ADDED TO SUPPORT COLOR
  1343. C  CRT'S THAT ARE BASICALLY VT100-LIKE WITH EXTENSIONS, OR VT100'S OR
  1344. C  EMULATORS WITH AVO OPTION.
  1345. C
  1346. C  OPERATION:
  1347. C    ON B+W VT100'S (WITH ADVANCED VIDEO), THE SET GRAPHICS CODES
  1348. C WILL BE USED AS FOLLOWS:
  1349. C  ALTERNATE ROWS WILL BE DISPLAYED IN BOLD
  1350. C  (ROW 3 TO 22 ONLY HOWEVER; THE REST IS NOT MATH AREA)
  1351. C COMMAND AND DISPLAY ROWS (23 AND 24 NORMALLY) WILL BE BOLDED ALWAYS.
  1352. C
  1353. C  IN COLOR MODE:
  1354. C    ON ED, SET BACKGROUND COLOR TO DARK BLUE
  1355. C    ALTERNATE ROWS WILL BE SET TO YELLOW OR GREEN
  1356. C  COLUMN LABEL ROW, LABEL ROW, AND ROW LABELS, AND COMMAND PROMPTS,
  1357. C  IN A DIFFERENT COLOR FOR EACH. DETERMINED AND SET AT TIME OF
  1358. C  CALL TO CURSOR POSITION.
  1359. C
  1360. C    AUTHOR:    GLENN EVERHART
  1361. C
  1362.       SUBROUTINE UVT100 ( CMD, N1, N2 )
  1363.       IMPLICIT INTEGER ( A - Z )
  1364.       DIMENSION PRL ( 6 )
  1365. C NOTE WE DECLARE THESE VARIABLES USED IN PORTACALC. THEY ARE ALL IN
  1366. C COMMONS, SO WE ADD NOTHING TO LENGTH OF THIS PROGRAM BY ADDING THEM.
  1367.     CHARACTER*1 FVLD
  1368.     DIMENSION FVLD(1,1)
  1369.     COMMON /FVLDC/FVLD
  1370. C ***<<<< RDD COMMON START >>>***
  1371.     InTeGer*4 RRWACT,RCLACT
  1372. C    COMMON/RCLACT/RRWACT,RCLACT
  1373.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  1374.      1  IDOL7,IDOL8
  1375. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  1376. C     1  IDOL7,IDOL8
  1377.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  1378. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  1379.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  1380. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  1381. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  1382. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  1383.     InTeGer*4 KLVL
  1384. C    COMMON/KLVL/KLVL
  1385.     InTeGer*4 IOLVL,IGOLD
  1386. C    COMMON/IOLVL/IOLVL
  1387. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  1388. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  1389.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  1390.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  1391.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  1392. C ***<<< RDD COMMON END >>>***
  1393. CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
  1394. CCC    InTeGer*4 LLCMD,LLDSP
  1395. CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  1396.     InTeGer*4 TYPE(1,1),VLEN(9)
  1397.     REAL*8 XVBLS(1,1)
  1398.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
  1399.     EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
  1400.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  1401. C ICPOS COMMON HAS PHYS COORDS BEING DISPLAYED. MUST QUERY FVLD TO
  1402. C SEE WHETHER TO INTENSIFY THE FIELD FOR NEGATIVE...
  1403. C ***<<< XVXTCD COMMON START >>>***
  1404.     CHARACTER*1 OARRY(100)
  1405.     InTeGer*4 OSWIT,OCNTR
  1406. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  1407. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  1408.     InTeGer*4 IC1POS,IC2POS,MODFLG
  1409. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  1410.        InTeGer*4 XTCFG,IPSET,XTNCNT
  1411.        CHARACTER*1 XTNCMD(80)
  1412. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  1413. C VARY FLAG ITERATION COUNT
  1414.     INTEGER KALKIT
  1415. C    COMMON/VARYIT/KALKIT
  1416.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  1417.     InTeGer*4 RCMODE,IRCE1,IRCE2
  1418. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1419. C     1  IRCE2
  1420. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  1421. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  1422. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  1423. C RCFGX ON.
  1424. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  1425. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  1426. C  AND VM INHIBITS. (SETS TO 1).
  1427.     INTEGER*4 FH
  1428. C FILE HANDLE FOR CONSOLE I/O (RAW)
  1429. C    COMMON/CONSFH/FH
  1430.     CHARACTER*1 ARGSTR(52,4)
  1431. C    COMMON/ARGSTR/ARGSTR
  1432.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
  1433.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  1434.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1435.      3  IRCE2,FH,ARGSTR
  1436. C ***<<< XVXTCD COMMON END >>>***
  1437. CCC    InTeGer*4 IC1POS,IC2POS,MODFLG
  1438. CCC    COMMON/ICPOS/IC1POS,IC2POS,MODFLG
  1439. C CONTROLS TO SET VARIOUS VISUAL ATTRIBUTES
  1440. C NORMAL, BOLD
  1441.     InTeGer*4 N1SV,N2SV,N222
  1442.     CHARACTER*1 CLSV(8)
  1443. c        CHARACTER*1 ULIT(8)
  1444. c    CHARACTER*1 NORMIT(4)
  1445.     CHARACTER*1 OUTBUF(16)
  1446. C    CHARACTER*1 NORMIT(4),BOLDIT(8),OUTBUF(16),BOLDUL(10)
  1447.     CHARACTER*2 OBF3
  1448.     CHARACTER*3 OBF6
  1449.     EQUIVALENCE (OBF3,OUTBUF(3)),(OBF6,OUTBUF(6))
  1450.     InTeGer*4 COLSW
  1451. C COLOR SCHEME CODED DATA ABOVE...
  1452.     DATA N222/0/
  1453.     DATA COLSW/0/
  1454. C LEAVE IN THE BOLDING FOR NEGATIVE NUMBERS
  1455. c    DATA NORMIT/'','[','0','m'/
  1456. C SET ATTRIBUTE 4 (UNDERLINE) RATHER THAN 1 (BOLD) FOR ALTERNATE LINES.
  1457. c fill in initial escape character (27 decimal)
  1458.       OUTBUF ( 1 ) = Char(27)
  1459.       DO 20000  I = 2, 16
  1460. c fill in spaces in out buffer (32 decimal = ascii space)
  1461.       OUTBUF ( I ) = Char(32)
  1462. 20000 CONTINUE
  1463. 20001 CONTINUE
  1464. C CMD 20 TURNS COLOR ON, 21 TURNS IT OFF.
  1465.       IF ( CMD .NE. 1) GOTO 20002
  1466. C CURSOR POSITION.
  1467. C SHIP OUT APPROPRIATE CHARACTERISTICS.
  1468.  
  1469. 7701    CONTINUE
  1470. 1754    CONTINUE
  1471. 1500    CONTINUE
  1472. 7711    CONTINUE
  1473.       OUTBUF ( 2 ) = '['
  1474.       IF (.NOT.( N1 .GT. 0 . AND . N1 .LE. (LLDSP+1) )) GOTO 20004
  1475.        WRITE(OBF3(1:2),10,ERR=20004)N1
  1476. C      ENCODE ( 2, 10, OUTBUF ( 3 ) ) N1
  1477. 20004 CONTINUE
  1478.       OUTBUF ( 5 ) = ';'
  1479. C ALLOW WIDE DISPLAYS FOR MACHINES LIKE THE RAINBOW...
  1480. C NOTE: USES MSDOS FORTRAN V3.2 FEATURE OF  I3.3 FORMAT...
  1481.       IF (.NOT.( N2 .GT. 0 . AND . N2 .LT. 233)) GOTO 20006
  1482.        WRITE(OBF6(1:3),105,ERR=20006)N2
  1483. C      ENCODE ( 3, 105, OUTBUF ( 6 ) ) N2
  1484. C FIX THE ABOVE FOR 132 COLUMN MAX ON RAINBOW. NO NEED TO LIMIT TO 80 COLS ON
  1485. C MACHINES THAT CAN HANDLE 132 OR MORE, BUT IBM MAY GOOF UP UNLESS LIMIT IS
  1486. C IN EFFECT. (LOSE LOSE)
  1487.     IF(OUTBUF(4).EQ.' ')OUTBUF(4)='0'
  1488.     IF(OUTBUF(7).EQ.' ')OUTBUF(7)='0'
  1489.     IF(OUTBUF(3).EQ.' ')OUTBUF(3)='0'
  1490.     IF(OUTBUF(6).EQ.' ')OUTBUF(6)='0'
  1491. 20006 CONTINUE
  1492.       OUTBUF ( 9 ) = 'H'
  1493.       LEN = 9
  1494.       GOTO 20003
  1495. 20002 CONTINUE
  1496.       IF ( CMD .NE. 11 ) GOTO 20036
  1497. C ERASE DISPLAY
  1498. C ALWSAYS ERASE WHOLE DISPLAY HERE.
  1499.     OUTBUF(1)=27
  1500.     call swrt(outbuf,1)
  1501.     call swrt('[0;0H',5)
  1502.     call swrt(outbuf,1)
  1503.     CALL SWRT('[2J',3)
  1504.     RETURN
  1505. 20036 CONTINUE
  1506.       IF ( CMD .NE. 12 ) GOTO 20042
  1507. C ERASE LINE
  1508. C EITHER ERASE WHOLE LINE BY DOING CR FIRST, OR JUST END OF LINE
  1509. C IF HE USED CODE 2.
  1510. C CAN'T HANDLE ERASING START ONLY, BUT ANALYTICALC NEVER TRIES THIS.
  1511. C DO C.R. FIRST IF CALLED FOR
  1512. 22001    CONTINUE
  1513.     if(n1.EQ.2)goto 20044
  1514. cc just emit line
  1515.     outbuf(1)=27
  1516.     outbuf(2)='['
  1517.     outbuf(3)='K'
  1518.     len=3
  1519.     goto 20003
  1520. C ERASE ALL BY RETURN, ERASE SEQ
  1521. 20044    outbuf(1)=13
  1522.     outbuf(2)=27
  1523.     outbuf(3)='['
  1524.     outbuf(4)='K'
  1525.       LEN = 4
  1526.       GOTO 20003
  1527. 20042 CONTINUE
  1528.       IF ( CMD .NE. 13 ) GOTO 20048
  1529. C SET GRAPHICS RENDITION (7=REVERSE VIDEO, 0=NORMAL,4=UNDERSCORE,1=BOLD
  1530. C  5=BLINK) (PORTACALC CALLS WITH 0 OR 7 (VT100 W/O AVO))
  1531. C    IF(MODFLG.NE.1)GOTO 22002
  1532. 22002    CONTINUE
  1533.     OUTBUF(1)=27
  1534.     call swrt(outbuf,1)
  1535.     IF(N1.EQ.7)CALL SWRT('[7m',3)
  1536.     if(n1.ne.7)call swrt('[0m',3)
  1537.     return
  1538. 20048 CONTINUE
  1539. c      IF (.NOT.( CMD .EQ. 15 )) GOTO 20054
  1540. C SCS. IGNORE THIS ... NEVER REALLY USED.
  1541.     RETURN
  1542. 20003 CONTINUE
  1543. 20073 CONTINUE
  1544. C USE A FORTRAN WRITE SO THIS WILL WORK ON VAX OR PDP11 (OR WHATEVER...)
  1545. C  UNIT 6 MUST BE THE TERMINAL...
  1546.     CALL SWRT(OUTBUF,LEN)
  1547. 10    FORMAT ( I2 )
  1548. 105    FORMAT(I3.3)
  1549.       RETURN
  1550.       END
  1551. c -h- varout.for    Fri Aug 22 13:37:17 1986    
  1552.     SUBROUTINE VAROUT (INDXX,IX2)
  1553. C COPYRIGHT (C) 1983 GLENN EVERHART
  1554. C ALL RIGHTS RESERVED
  1555. C 60=MAX REAL ROWS
  1556. C 301=MAX REAL COLS
  1557. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  1558. C VBLS AND TYPE DIMENSIONED 60,301
  1559. C
  1560. C **************************************************
  1561. C *                                                *
  1562. C *       SUBROUTINE   VAROUT                      *
  1563. C *                                                *
  1564. C **************************************************
  1565. C
  1566. C
  1567. C
  1568. C  OUTPUTS THE VALUE OF THE VARIABLE POINTED TO BY INDXX.
  1569. c modified version - multiple precision calls diked out - gce
  1570. C
  1571. C  ASCII     A1 FORMAT UNLESS THE ASCII VALUE IS LESS THAN 32.
  1572. C            IN SUCH CASES, 32 IS ADDED TO THE VALUE AND THE
  1573. C            CHARACTER IS OUTPUT  SO THAT IT IS PRECEDED BY THE
  1574. C            CHARACTER '^'.
  1575. C
  1576. C  DECIMAL   A COMPUTED F FORMAT.
  1577. C
  1578. C  HEXADECIMAL  LEADING ZEROES, "BASE 16" QUE.
  1579. C
  1580. C  INTEGER   I12 FORMAT
  1581. C
  1582. C  OCTAL     LEADING ZEROES, "BASE 8" QUE
  1583. C
  1584. C  REAL      D25.18 FORMAT
  1585. C
  1586. C
  1587. C  VAROUT CALLS
  1588. C
  1589. C ERRMSG   PRINTS OUT ERROR MESSAGES
  1590. C MOUT     OUTPUTS MULTIPLE PRECISION NUMBERS
  1591. C
  1592. C
  1593. C
  1594. C
  1595. C
  1596. C VAROUT IS CALLED BY CALC AND POSTVL
  1597. C
  1598. C
  1599. C
  1600. C  VARIABLE   USE
  1601. C
  1602. C  DEC        HOLDS NUMBER OF DIGITS TO THE RIGHT OF THE
  1603. C             DECIMAL POINT IN F FORMAT SPECIFICATION.
  1604. C  DFORM(11)  HOLDS FORMAT SPECIFICATION FOR F FORMAT
  1605. C             (OUTPUTTING VALUE OF VARIABLES WITH DECIMAL DATA TYPE).
  1606. C  DIGITS     HOLDS THE ASCII CHARACTERS FOR VARIOUS DIGITS.
  1607. C  EIGHT(8)   USED TO PICK OFF REAL*8 'S FROM VBLS.
  1608. C             ALSO HOLDS HEXADECIMAL DIGITS IF # IS DATA TYPE HEX.
  1609. C  FOUR(4)    USED TO PICK OFF INTEGER*4'S FROM VBLS.
  1610. C  I,K        HOLDS TEMPORARY VALUES.
  1611. C  I1         HOLDS THE FIRST DIGIT IN CREATING AN F FORMAT SPECIFICATION.
  1612. C  I2         HOLDS THE SECOND DIGIT IN CREATING AN F FORMAT SPEC.
  1613. C  INDXX      POINTS TO VARIABLE BEING OUTPUT.
  1614. C  IPT        POINTER FOR DFORM.
  1615. C  ISV        POINTER FOR VECTOR SIGN(2).
  1616. C  ITWO       TWO IS USED TO PICK OFF A BYTE OF THE INTEGER
  1617. C  TWO(2)     REPRESENTATION. THEN ITWO IS USED AS
  1618. C             THE VALUE. THIS IS DONE BECAUSE OTHERWISE
  1619. C             SOME COMPILERS WOULD FORCE A SIGN EXTEND.
  1620. C  L          TEMPORARY VALUES. POINTER FOR EIGHT(8).
  1621. C  LEVIN(11)  HOLDS PRINTABLE ASCII CHARACTERS WHICH REPRESENT
  1622. C             AN OCTAL NUMBER. EQUIVALENCED WITH EIGHT(8).
  1623. C  M1         HOLDS HIGH ORDER HEXADECIMAL DIGIT.
  1624. C  M2         HOLDS LOW ORDER HEXADECIMAL DIGIT.
  1625. C  MAG        HOLDS THE MAGNITUDE OF A REAL*8 NUMBER
  1626. C  P10        REAL*8 THAT HOLDS POWERS OF 10. (DECIMAL)
  1627. C  RETCD      HOLDS RETURN CODE FROM CALL TO MOUT.
  1628. C  RPAR       ')'
  1629. C  SIGN(2)    HOLDS PRINTABLE ASCII CHARACTERS FOR OUTPUTTING THE
  1630. C             SIGN OF A NUMBER.
  1631. C  STAR1      HOLDS A SINGLE CHARACTER.
  1632. C  VBLS(100,27)  HOLDS VALUE FOR EACH VARIABLE.
  1633. C  WIDTH      WIDTH SPECIFICATION FOR F FORMAT.
  1634. C
  1635. C
  1636. C
  1637. C    SUBROUTINE VAROUT (INDXX,IX2)
  1638. C
  1639. C NOTE THAT VAROUT IS USED TO DUMP ONLY VALUES FROM AVBLS, NOT
  1640. C VBLS (IX2=1 ALWAYS AT CALLS). THUS DON'T BOTHER TO PICK UP
  1641. C ANY FURTHER INFO FROM VBLS HERE.
  1642.     REAL*8 REAL,MAG,P10
  1643. C
  1644.     INTEGER*4 INT,L,K
  1645. C
  1646.     InTeGer*4 ITWO,INDXX
  1647.     InTeGer*4 TYPE(1,1),WIDTH,DEC,VLEN(9),RETCD
  1648. C
  1649.     CHARACTER*1 AVBLS(20,27),STAR1,EIGHT(8),FOUR(4)
  1650.     CHARACTER*1 VBLS(8,1,1)
  1651.     CHARACTER*1 TWO(2)
  1652.     CHARACTER*1 DFORM(11),DIGITS(16,3),LEVIN(11)
  1653.     CHARACTER*11 DFORM1
  1654.     EQUIVALENCE(DFORM1(1:1),DFORM(1))
  1655.     CHARACTER*1 SIGN(2)
  1656.     CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
  1657. C ***<<< XVXTCD COMMON START >>>***
  1658.     CHARACTER*1 OARRY(100)
  1659.     InTeGer*4 OSWIT,OCNTR
  1660. C    COMMON/OAR/OSWIT,OCNTR,OARRY
  1661. C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
  1662.     InTeGer*4 IPS1,IPS2,MODFLG
  1663. C    COMMON/ICPOS/IPS1,IPS2,MODFLG
  1664.        InTeGer*4 XTCFG,IPSET,XTNCNT
  1665.        CHARACTER*1 XTNCMD(80)
  1666. C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
  1667. C VARY FLAG ITERATION COUNT
  1668.     INTEGER KALKIT
  1669. C    COMMON/VARYIT/KALKIT
  1670.     InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
  1671.     InTeGer*4 RCMODE,IRCE1,IRCE2
  1672. C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1673. C     1  IRCE2
  1674. C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
  1675. C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
  1676. C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
  1677. C RCFGX ON.
  1678. C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
  1679. C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
  1680. C  AND VM INHIBITS. (SETS TO 1).
  1681.     INTEGER*4 FH
  1682. C FILE HANDLE FOR CONSOLE I/O (RAW)
  1683. C    COMMON/CONSFH/FH
  1684.     CHARACTER*1 ARGSTR(52,4)
  1685. C    COMMON/ARGSTR/ARGSTR
  1686.     COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
  1687.      1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
  1688.      2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
  1689.      3  IRCE2,FH,ARGSTR
  1690. C ***<<< XVXTCD COMMON END >>>***
  1691. CCC    InTeGer*4 OSWIT,OCNTR
  1692. C NOTE: OSWIT NONZERO MEANS OUTPUT TO OARRY.
  1693. C OSWIT=2 MEANS NO ZEROING OF OARRY; NOTHING MUCH COMES OUT.
  1694. CCC    CHARACTER*1 OARRY(100)
  1695. CCC    COMMON/OAR/OSWIT,OCNTR,OARRY
  1696. C
  1697.     COMMON /V/ TYPE,AVBLS,VBLS,VLEN
  1698.     COMMON /DIGV/ DIGITS
  1699.     COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
  1700. C
  1701.     EQUIVALENCE (TWO,ITWO)
  1702.     EQUIVALENCE (REAL,EIGHT),(INT,FOUR),(EIGHT,LEVIN)
  1703. C
  1704.     DATA SIGN/' ','-'/
  1705.     DATA DFORM /'(', '1', 'X', ',', 'F', ' ', ' ', '.', ' ', ' ',
  1706.      ;  ')'/
  1707.     DATA ITWO/0/
  1708. C
  1709. C
  1710. C
  1711.     CALL TYPGET(INDXX,IX2,K)
  1712. C    K=TYPE(INDXX,IX2)
  1713.     IF (K.GT.0) GOTO 10
  1714. C MODIFY TO ELIMINATE CALL TO ERRMSG HERE. JUST COMPLAIN LOCALLY.
  1715.     CALL SWRT('Invalid type argument',21)
  1716.     oarry(1)=13
  1717.     oarry(2)=10
  1718.     call swrt(oarry,2)
  1719. C    CALL ERRMSG (16)
  1720.     GOTO 10000
  1721. 10    GOTO (100,200,300,400,500,600,700,800,900),K
  1722.     STOP 10
  1723. C
  1724. C
  1725. C
  1726. C
  1727. C **************************************************
  1728. C **************        ASCII        ***************
  1729. C **************************************************
  1730. 100    STAR1=AVBLS(1,INDXX)
  1731.     IF(OSWIT.NE.0)GOTO 6006
  1732.     IF (ICHAR(STAR1).LT.32) GOTO 110
  1733. 102    WRITE (18,103) STAR1
  1734. 103    FORMAT (1X,A1)
  1735.     RETURN
  1736. 110    STAR1=CHAR(ICHAR(STAR1)+32)
  1737.     WRITE (18,112) STAR1
  1738. 112    FORMAT (1X,'^',A1)
  1739.     RETURN
  1740. 6006    OARRY(1)=STAR1
  1741.     OCNTR=1
  1742.     RETURN
  1743. C
  1744. C
  1745. C
  1746. C
  1747. C
  1748. C **************************************************
  1749. C ****************  DECIMAL   **********************
  1750. C **************************************************
  1751. 200    CONTINUE
  1752.     DO 208 I=1,8
  1753. 208    EIGHT(I)=AVBLS(I,INDXX)
  1754.     MAG=DABS(REAL)
  1755.     IF (MAG.LT.1.D0) GOTO 240
  1756. C
  1757. C
  1758. C COUNT THE # OF DIGITS TO THE LEFT OF THE DECIMAL POINT
  1759.     P10=1.D0
  1760.     DO 210 I=1,38
  1761.     P10=10.D0*P10
  1762.     IF (P10.GT.MAG) GOTO 212
  1763. 210    CONTINUE
  1764. C
  1765. C I COUNTS THE # OF DIGITS TO THE LEFT OF THE DECIMAL POINT
  1766.     I=39
  1767. 212    DEC=0
  1768.     WIDTH=17
  1769.     IF(I.GT.15)WIDTH=I+2
  1770.     IF(I.LE.15)DEC=15-I
  1771. C
  1772. C
  1773. C  CREATE PROPER FORMAT STATEMENT
  1774. 215    I1=WIDTH/10
  1775.     I2=WIDTH-I1*10
  1776.     IF (I2.EQ.0) I2=10
  1777.     DFORM(6)=DIGITS(I1,1)
  1778.     DFORM(7)=DIGITS(I2,1)
  1779.     I1=DEC/10
  1780.     I2=DEC-I1*10
  1781.     IF (I1.EQ.0) I1=10
  1782.     IF (I2.EQ.0) I2=10
  1783.     IPT=9
  1784.     IF (I1.EQ.0) GOTO 220
  1785.     DFORM(9)=DIGITS(I1,1)
  1786.     IPT=IPT+1
  1787. 220    DFORM(IPT)=DIGITS(I2,1)
  1788.     DFORM(IPT+1)=RPAR
  1789.     nnn=ipt+2
  1790.     if(nnn.ge.11)goto 223
  1791.     do 224 nnnn=nnn,11
  1792. 224    dform(nnnn)=' '
  1793. 223    continue
  1794. C
  1795. C
  1796. C
  1797. C
  1798. C  OUTPUT REAL USING NEWLY CREATED
  1799. C  FORMAT STATEMENT HELD BY DFORM
  1800.     IF(OSWIT.NE.0)GOTO 6009
  1801.     WRITE (18,DFORM,ERR=10000) REAL
  1802.     GOTO 10000
  1803. 6009    CONTINUE
  1804.     IF(OSWIT.EQ.2) GOTO 6101
  1805.     IF(OSWIT.GT.3)GOTO 7101
  1806.     DO 6010 OCNTR=1,106
  1807. 6010    OARRY(OCNTR)=0
  1808. 6101    CONTINUE
  1809. C FORGET THE ENCODE ... NEVER USED
  1810. C6101    ENCODE(100,DFORM,OARRY)REAL
  1811. 7101    OCNTR=100
  1812.     GOTO 10000
  1813. C
  1814. C
  1815. C  REAL LESS THAN 1.D0
  1816. 240    P10=1.D0
  1817.     DO 245 I=1,38
  1818.     P10=P10*.1D0
  1819.     IF (MAG.GE.P10) GOTO 250
  1820. 245    CONTINUE
  1821.     I=0
  1822. C
  1823. C I-1 REPRESENTS THE NUMBER OF LEADING ZEROS
  1824. 250    DEC=14+I
  1825.     WIDTH=DEC+3
  1826.     GOTO 215
  1827. C
  1828. C
  1829. C **************************************************
  1830. C *************  HEXADECIMAL  **********************
  1831. C **************************************************
  1832. C  HEXADECIMAL
  1833. 300    CONTINUE
  1834.     DO 302 I=1,4
  1835. 302    FOUR(I)=AVBLS(I,INDXX)
  1836.     ISV=1
  1837.     IF (INT.LT.0) ISV=2
  1838.     INT=IABS(INT)
  1839.     L=8
  1840.     DO 304 I=1,4
  1841. C PICK UP A VALUE, THEN USE InTeGer*4 EQUIVALENT
  1842. C TO WORK WITH SO SIGN DOESN'T GET EXTENED.
  1843.     TWO(1)=ICHAR(FOUR(I))
  1844.     M1=ITWO/16
  1845.     M2=ITWO-M1*16
  1846.     IF(M1.EQ.0)M1=16
  1847.     IF(M2.EQ.0)M2=16
  1848.     EIGHT(L)=DIGITS(M2,3)
  1849.     L=L-1
  1850.     EIGHT(L)=DIGITS(M1,3)
  1851.     L=L-1
  1852. 304    CONTINUE
  1853.     IF(OSWIT.NE.0)GOTO 6011
  1854.     WRITE (18,310,ERR=10000) SIGN(ISV), EIGHT
  1855. 310    FORMAT (1X,1A1,8A1,2X,'(BASE 16)')
  1856.     GOTO 10000
  1857. 6011    CONTINUE
  1858.     IF(OSWIT.EQ.2)GOTO 6102
  1859.     IF(OSWIT.GT.3)GOTO 7102
  1860.     DO 6013 OCNTR=1,106
  1861. 6013    OARRY(OCNTR)=0
  1862. 6102    CONTINUE
  1863. C FORGET UNUSED ENCODE
  1864. C6102    ENCODE(8,6012,OARRY)SIGN(ISV),EIGHT
  1865. 6012    FORMAT(A1,8A1)
  1866. 7102    OCNTR=9
  1867.     GOTO 10000
  1868. C
  1869. C
  1870. C **************************************************
  1871. C ***************   INTEGER   **********************
  1872. C **************************************************
  1873. 400    DO 404 I=1,4
  1874. 404    FOUR(I)=AVBLS(I,INDXX)
  1875.     IF(OSWIT.NE.0)GOTO 6014
  1876.     WRITE (18,410,ERR=10000) INT
  1877. 410    FORMAT (1X,I12)
  1878.     GOTO 10000
  1879. 6014    CONTINUE
  1880.     IF(OSWIT.EQ.2)GOTO 6103
  1881.     IF(OSWIT.GT.3)GOTO 7104
  1882.     DO 6015 OCNTR=1,106
  1883. 6015    OARRY(OCNTR)=0
  1884. 6103    CONTINUE
  1885. C6103    ENCODE(12,410,OARRY)INT
  1886. 7104    OCNTR=12
  1887.     GOTO 10000
  1888. C
  1889. C
  1890. C **************************************************
  1891. C ***********    MULTIPLE PRECISION   **************
  1892. C **************************************************
  1893. C  MULTIPLE PRECISION
  1894. C  M10
  1895. 500    CONTINUE
  1896. C
  1897. C  M8
  1898. 600    CONTINUE
  1899. C
  1900. C  M16
  1901. 700    continue
  1902. c700    CALL MOUT (INDXX,RETCD)
  1903.     GOTO 10000
  1904. C
  1905. C
  1906. C **************************************************
  1907. C ****************   OCTAL   ***********************
  1908. C **************************************************
  1909. C  OCTAL
  1910. 800    DO 804 I=1,4
  1911. 804    FOUR(I)=AVBLS(I,INDXX)
  1912.     ISV=1
  1913.     IF (INT.LT.0) ISV=2
  1914.     K=IABS(INT)
  1915.     DO 810 I=1,11
  1916.     L=K-K/8*8
  1917. C TAKE ABSOLUTE VALUE IN CASE FIRST IABS DIDN'T WORK ON -2**31
  1918.     L=IABS(L)
  1919.     IF(L.EQ.0)L=9
  1920.     LEVIN (12-I)=DIGITS(L,2)
  1921.     K=K/8
  1922. 810    CONTINUE
  1923.     IF(OSWIT.NE.0)GOTO 6016
  1924.     WRITE (18,820,ERR=10000) SIGN(ISV), LEVIN
  1925. 820    FORMAT (1X,1A1,11A1,2X,'(BASE 8)')
  1926.     GOTO 10000
  1927. 6016    CONTINUE
  1928.     IF(OSWIT.EQ.2)GOTO 6100
  1929.     IF(OSWIT.GT.3)GOTO 7105
  1930.     DO 6018 OCNTR=1,106
  1931. 6018    OARRY(OCNTR)=0
  1932. 6100    CONTINUE
  1933. C6100    ENCODE(12,6017,OARRY)SIGN(ISV),LEVIN
  1934. 6017    FORMAT(12A1)
  1935. 7105    OCNTR=12
  1936.     GOTO 10000
  1937. C
  1938. C
  1939. C
  1940. C
  1941. C
  1942. C **************************************************
  1943. C ***************    REAL    ***********************
  1944. C **************************************************
  1945. 900    DO 904 I=1,8
  1946. 904    EIGHT(I)=AVBLS(I,INDXX)
  1947.     IF(OSWIT.NE.0)GOTO 6019
  1948.     WRITE (18,910,ERR=10000) REAL
  1949. 910    FORMAT (1X,D25.18)
  1950.     GOTO 10000
  1951. 6019    CONTINUE
  1952.     IF (OSWIT.EQ.2)GOTO 6020
  1953.     IF(OSWIT.GT.3)GOTO 7106
  1954.     DO 6321 OCNTR=1,106
  1955. 6321    OARRY(OCNTR)=Char(0)
  1956. 6020    CONTINUE
  1957. C    ENCODE(28,6021,OARRY)REAL
  1958. 6021    FORMAT(D25.18)
  1959. 7106    OCNTR=28
  1960. 10000    RETURN
  1961.     END
  1962. c -h- vblget.for    Fri Aug 22 13:37:17 1986    
  1963.         SUBROUTINE VBLGET(ID1,ID2,ID3,IVAL)
  1964. C
  1965. C VBLGET - GET BYTE OF 3 DIM VBLS ARRAY, ORIGINALLY
  1966. C  DIMENSIONED (8,60,301). HANDLE BY CALLING XVBLGT TO GET
  1967. C  CORRECT 8 BYTE VARIABLE, AND PULLING OUT CORRECT ONE
  1968.         InTeGer*4 ID1,ID2,ID3
  1969.         CHARACTER*1 IVAL,LL(8)
  1970.         REAL*8 XX
  1971.         EQUIVALENCE(LL(1),XX)
  1972.         CALL XVBLGT(ID2,ID3,XX)
  1973.         IVAL=LL(ID1)
  1974.         RETURN
  1975.         END
  1976. c -h- vblset.for    Fri Aug 22 13:37:17 1986    
  1977.         SUBROUTINE VBLSET(ID1,ID2,ID3,IVAL)
  1978. C VBLSET - SET BYTE OF 3 DIM VBLS ARRAY, ORIGINALLY
  1979. C  DIMENSIONED (8,60,301). HANDLE BY CALLING XVBLST TO GET
  1980. C  CORRECT 8 BYTE VARIABLE, AND PUTTING IN CORRECT ONE
  1981.         InTeGer*4 ID1,ID2,ID3
  1982.         CHARACTER*1 IVAL,LL(8)
  1983.         REAL*8 XX
  1984.         EQUIVALENCE(LL(1),XX)
  1985. C GET THE DESIRED 8 BYTES, THEN CHANGE THE ONE WE WANT. THEN...
  1986.         CALL XVBLGT(ID2,ID3,XX)
  1987.         LL(ID1)=IVAL
  1988. C PUT BACK THE 8 BYTES.
  1989.         CALL XVBLST(ID2,ID3,XX)
  1990.         RETURN
  1991.         END
  1992. c -h- wassig.fdd    Fri Aug 22 13:44:20 1986    
  1993.     SUBROUTINE WASSIG(IUNIT,NAME)
  1994. C
  1995. C
  1996.     CHARACTER*1 NAME(50)
  1997.     InTeGer*4 IUNIT
  1998.     CHARACTER*20 WK
  1999.     CHARACTER*1 WK1(20)
  2000.     EQUIVALENCE(WK(1:1),WK1(1))
  2001. C JUST TRY AND NULL FILL A NAME TO USE.
  2002.     DO 1 N=1,20
  2003.     WK1(N)=' '
  2004. 1    CONTINUE
  2005.     DO 2 N=1,20
  2006.     II=ICHAR(NAME(N))
  2007.     IF(II.LT.32)GOTO 3
  2008.     WK1(N)=CHAR(II)
  2009. C1    CONTINUE
  2010. 2    CONTINUE
  2011. 3    OPEN(IUNIT,FILE=WK(1:20),STATUS='NEW',
  2012.      1  ACCESS='SEQUENTIAL',FORM='FORMATTED')
  2013.     RETURN
  2014.     END
  2015. c -h- wrkfil.f40    Fri Aug 22 13:44:46 1986    
  2016.     SUBROUTINE WRKFIL(NREC,ARRAY,IFUNC)
  2017. C COPYRIGHT 1983 GLENN C.EVERHART
  2018. C ALL RIGHTS RESERVED
  2019. C WORKFILE PSEUDO-MAINTAINER
  2020. C
  2021. C THIS ROUTINE IS INTENDED TO PERMIT THE SCRATCH FILE OF
  2022. C PORTACALC TO BE DISPENSED WITH BY USING A LARGE IN-MEMORY
  2023. C ARRAY. A BITMAP WILL SET UP WHEN THE ELEMENT IS INIT'ED AND
  2024. C THE DEFAULT ELEMENT WILL BE COMPUTED AND RETURNED
  2025. C IF AN UNINITIALIZED ELEMENT IS USED.
  2026. C
  2027. c nrc was i*4. make it i*2 here
  2028.     INTEGER NRC
  2029. C    InTeGer*4 NRC2(2)
  2030. C    EQUIVALENCE(NRC2(1),NRC)
  2031. C RECORD NUMBER TO ACCESS
  2032.     INTEGER NREC
  2033.     CHARACTER*1 ARRAY(128)
  2034.     INTEGER IFUNC
  2035. C ***<<<< RDD COMMON START >>>***
  2036.     InTeGer*4 RRWACT,RCLACT
  2037. C    COMMON/RCLACT/RRWACT,RCLACT
  2038.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2039.      1  IDOL7,IDOL8
  2040. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2041. C     1  IDOL7,IDOL8
  2042.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2043. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2044.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2045. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2046. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2047. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2048.     InTeGer*4 KLVL
  2049. C    COMMON/KLVL/KLVL
  2050.     InTeGer*4 IOLVL,IGOLD
  2051. C    COMMON/IOLVL/IOLVL
  2052. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2053. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2054.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2055.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2056.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2057. C ***<<< RDD COMMON END >>>***
  2058. CCC    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2059. CCC    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2060. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2061. C
  2062. C ***<<< NULETC COMMON START >>>***
  2063.     InTeGer*4 ICREF,IRREF
  2064. C    COMMON/MIRROR/ICREF,IRREF
  2065.     InTeGer*4 MODPUB,LIMODE
  2066. C    COMMON/MODPUB/MODPUB,LIMODE
  2067.     InTeGer*4 KLKC,KLKR
  2068.     REAL*8 AACP,AACQ
  2069. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  2070.     InTeGer*4 NCEL,NXINI
  2071. C    COMMON/NCEL/NCEL,NXINI
  2072.     CHARACTER*1 NAMARY(20,301)
  2073. C    COMMON/NMNMNM/NAMARY
  2074.     InTeGer*4 NULAST,LFVD
  2075. C    COMMON/NULXXX/NULAST,LFVD
  2076.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  2077.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  2078. C ***<<< NULETC COMMON END >>>***
  2079. CCC    InTeGer*4 NCEL,NXINI
  2080. CCC    COMMON/NCEL/NCEL,NXINI
  2081.     InTeGer*4 MFID(2),MFMOD(2)
  2082.     InTeGer*2 IFID(8,2048)
  2083.     COMMON/IFIDC/IFID
  2084. CCC    InTeGer*4 RRWACT,RCLACT
  2085. C MFLAST = 1 OR 2 FOR LAST BUFFER USED. MFBASE IS HOLDER FOR "BASE ADDR"
  2086. C IN ARRAY TO USE IN SCANS.
  2087.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  2088.     COMMON/VBCTL/MFLAST,MFBASE,MVLASE,MVBASE
  2089. CCC    COMMON/RCLACT/RRWACT,RCLACT
  2090.     CHARACTER*1 LFID(16,2048)
  2091.     EQUIVALENCE(IFID(1,1),LFID(1,1))
  2092. C ***<<< KLSTO COMMON START >>>***
  2093.     InTeGer*4 DLFG
  2094. C    COMMON/DLFG/DLFG
  2095.     InTeGer*4 KDRW,KDCL
  2096. C    COMMON/DOT/KDRW,KDCL
  2097.     InTeGer*4 DTRENA
  2098. C    COMMON/DTRCMN/DTRENA
  2099.     REAL*8 EP,PV,FV
  2100.     DIMENSION EP(20)
  2101.     INTEGER*4 KIRR
  2102. C    COMMON/ERNPER/EP,PV,FV,KIRR
  2103.     InTeGer*4 LASTOP
  2104. C    COMMON/ERROR/LASTOP
  2105.     CHARACTER*1 FMTDAT(9,76)
  2106. C    COMMON/FMTBFR/FMTDAT
  2107.     CHARACTER*1 EDNAM(16)
  2108. C    COMMON/EDNAM/EDNAM
  2109. c    InTeGer*4 MFID(2),MFMOD(2)
  2110. C    COMMON/FRM/MFID,MFMOD
  2111.     InTeGer*4 JMVFG,JMVOLD
  2112. C    COMMON/FUBAR/JMVFG,JMVOLD
  2113.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  2114.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  2115. C ***<<< KLSTO COMMON END >>>***
  2116. CCC    COMMON/FRM/MFID,MFMOD
  2117.     CHARACTER*1 LI,IBYTE
  2118. C DEFFMT IS THE DEFAULT FORMAT FOR NUMERICS. INITIALLY IT WILL BE F9.2
  2119.     CHARACTER*1 DVFMT(12),DEFFMT(10)
  2120.     EQUIVALENCE(DVFMT(2),DEFFMT(1))
  2121.     COMMON/DEFVBX/DVFMT
  2122. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  2123. C AREAS WITH DATA.)
  2124. CCC    CHARACTER*1 FMTDAT(9,76)
  2125. CCC    COMMON/FMTBFR/FMTDAT
  2126. C
  2127. C IFUNC SPECIFIES WHAT TO DO:
  2128. C    =0    READ INTO ARRAY
  2129. C    =1    WRITE FROM ARRAY INTO WRKARY
  2130. C    =2    INITIALIZE (JUST CLEARS BITMAP HERE)(OPEN)
  2131. C    =3    CLOSE (CLEARS BITMAP HERE)
  2132.     CHARACTER*1 DTBL1(9,9,8)
  2133. C BIG WASTEFUL TABLE TO INIT OPERATION TYPE DATA. TRY TO REUSE SPACE.
  2134.     InTeGer*2 BTBL(6,6,8)
  2135. C REUSE SPACE BY MAKING LFID AND IT OVERLAY EACH OTHER.
  2136. C NO NEED TO WASTE IT.
  2137.     INTEGER DTBLIN
  2138. C DTBLIN FLAGS THAT DTBL1 WAS ALREADY INITED, SO ONLY DOES SO ONCE.
  2139.     EQUIVALENCE(LFID(1,1),BTBL(1,1,1))
  2140.     InTeGer*2 BTBL1(6,6)
  2141.     InTeGer*2 BTBL2(6,6),BTBL3(6,6),BTBL4(6,6),BTBL5(6,6)
  2142.     InTeGer*2 BTBL6(6,6),BTBL7(6,6),BTBL8(6,6)
  2143.     EQUIVALENCE(BTBL(1,1,1),BTBL1(1,1)),(BTBL(1,1,2),BTBL2(1,1))
  2144.     EQUIVALENCE(BTBL(1,1,3),BTBL3(1,1)),(BTBL(1,1,4),BTBL4(1,1))
  2145.     EQUIVALENCE(BTBL(1,1,5),BTBL5(1,1)),(BTBL(1,1,6),BTBL6(1,1))
  2146.     EQUIVALENCE(BTBL(1,1,7),BTBL7(1,1)),(BTBL(1,1,8),BTBL8(1,1))
  2147.     COMMON /DECIDE/ DTBL1
  2148.     DATA DTBLIN/0/
  2149.     IF(IFUNC.NE.50)GOTO 34
  2150.     IF(DTBLIN.NE.0)RETURN
  2151.     DTBLIN=1
  2152. C FLAG WE DID THIS INITIALIZATION ONCE. SINCE BUFFER IS CLEARED WE MUST
  2153. C *** NOT *** DO IT AGAIN.
  2154. C ONLY INIT DTBL1 ENTRIES NOT CORRESPONDING TO MULTIPLE PRECISION DATA
  2155. C TYPES (WHICH ARE NOT SUPPORTED HERE)
  2156. C CALL SEPARATE ROUTINE TO CLEAR OUT THIS STUFF ONE-TIME. OVERLAY SAME.
  2157. C NOTE LOTS OF SILLY ARGUMENTS TO SUBROUTINE SINCE MS FORTRAN DISALLOWS
  2158. C EQUIVALENCES TO DUMMY ARGUMENTS.
  2159.     CALL WTBINI(IFID,LPGMXF,BTBL1,BTBL2,BTBL3,BTBL4,BTBL5,BTBL6,
  2160.      1  BTBL7,BTBL8)
  2161. C
  2162. C14      CONTINUE
  2163. CC FILE IS NOW CLEARED
  2164.     RETURN
  2165. 34    IF(IFUNC.LT.0.OR.IFUNC.GT.3)RETURN
  2166.     JFUN=IFUNC+1
  2167.     GOTO (1000,2000,3000,4000),JFUN
  2168. 1000    CONTINUE
  2169. C READ
  2170.     CALL FVLDGT(NREC,1,IBYTE)
  2171.     IF(ICHAR(IBYTE).NE.0)GOTO 1001
  2172. C UNINITIALIZED ARRAY ELEMENT: SET IT UP.
  2173. C JUST LEAVES DUMMY CELL CONTENTS WHERE NOTHING IS REALLY INIT'D.
  2174.     DO 1003 N=1,128
  2175. 1003    ARRAY(N)=char(0)
  2176.     ARRAY(1)='P'
  2177.     ARRAY(2)='#'
  2178.     ARRAY(3)='0'
  2179.     ARRAY(5)='0'
  2180.     ARRAY(4)='#'
  2181.     ARRAY(118)=CHAR(15)
  2182. C NOTE ARRAY(119) (WHICH BECOMES FVLD) IS 0 TOO.
  2183.     DO 1004 N=1,9
  2184. 1004    ARRAY(N+119)=DEFFMT(N)
  2185. C RETURN THE DEFAULT FORMAT NOW.
  2186.     RETURN
  2187. 1001    CONTINUE
  2188. C HERE HAVE TO GET THE WHOLE THING REALLY
  2189.     DO 1053 N=1,128
  2190. 1053    ARRAY(N)=char(0)
  2191.     ARRAY(119)=IBYTE
  2192.     ARRAY(118)=CHAR(15)
  2193.     ARRAY(1)=char(48)
  2194. C LET ARRAY INITIALLY BE SET SENSIBLY..
  2195.     DO 1054 N=1,9
  2196. 1054    ARRAY(N+119)=DEFFMT(N)
  2197. C WE MAY MODIFY FORMAT LATER TOO...
  2198. C NOW HAVE A NON-DEFAULT ELEMENT TO READ... GO THROUGH SYMBOL TBL LOGIC
  2199. C FOR THESE, WE USE 16-BYTE "CELLS" WHICH HAVE THE FOLLOWING FORMAT:
  2200. C    ID    2 BYTES (CELL ADDRESS, MUST BE 1 OR MORE FOR VALID)
  2201. C    FLAG    1 BYTE  (TYPE OF CELL:
  2202. C                0 = UNUSED
  2203. C                1 = 1 OF 1 CELLS
  2204. C                2 = NONTERMINAL OF MORE THAN 1 CELL
  2205. C                3 = LAST OF >1 CELLS
  2206. C    FORMAT    1 BYTE  (INDEX OF FORMAT STRING FOR THIS CELL; FORMATS
  2207. C                ARE STORED RESIDENT, UP TO 76 OF THEM,
  2208. C                SET BY DF COMMAND.)
  2209. C    FORMULA    12 BYTES  (FORMULA TEXT)
  2210. C SET UP HASH CODE NOW FOR THE WAY WE NEED...
  2211. C    IPM=(LPGMXF*64/2048)+1
  2212. C    IBF=64
  2213. CC    IBF=(2048+31)/32
  2214. C IBF IS NO. OF ENTRIES IN A BUFFER. OF 512 BYTES
  2215. C    IBF=32
  2216.     IBF=32
  2217. C    LLL=(LPGMXF)/IBF
  2218. C    LLL=LPGMXF
  2219. C IPM IS NO. PAGES MAX IN FILS
  2220.     IPM=LPGMXF/16
  2221. C EACH BUFFER HAS 16KB SO MAX PAGES IS (FILE LENGTH)/16
  2222. C    IPM=LLL
  2223.     IF(IPM.LT.2)IPM=2
  2224. C FORCE IPM (MAX MEM PAGE) TO BE IN VALID RANGE
  2225.     IHASH=NREC
  2226. C    JHASH=IMASK(IHASH,2047)
  2227.     JHASH=MOD(IHASH,1024)
  2228. C    JHASH=IMASK(IHASH,1023)
  2229. C    JHASH=MOD(IHASH,2048)
  2230.     IF(LPGMOD.NE.0)GOTO 5305
  2231. C    IPAG=(IHASH/2048)+1
  2232.     IPAG=(IHASH/1024)+1
  2233.     IPAG=MOD(IPAG,IPM)+1
  2234.     GOTO 5306
  2235. 5305    CONTINUE
  2236. C SPEED OPTIMAL PACK
  2237.     FPG=FLOAT(IHASH)*FLOAT(IPM)/FLOAT(LPGMOD)
  2238.     IPAG=FPG
  2239.     IPAG=MOD(IPAG,IPM)
  2240.     IPAG=IPAG+1
  2241. C    IPAG=1+(IHASH*IPM)/18060
  2242. 5306    CONTINUE
  2243. C HERE DECIDED IF PAGE IS WHAT WE NEED.
  2244. C
  2245. C    IF(IPAG.LE.0)IPAG=1
  2246. C DETERMINE FIRST THAT NEITHER PAGE NUMBER IS ZERO.
  2247.     IF(IPAG.EQ.MFID(1).OR.IPAG.EQ.MFID(2))GOTO 853
  2248.     IF(MFID(1).NE.0)GOTO 852
  2249.     MFID(1)=IPAG
  2250.     GOTO 853
  2251. 852    IF(MFID(2).EQ.0)MFID(2)=IPAG
  2252. 853    CONTINUE
  2253.     IF(MFID(1).EQ.IPAG) GOTO 850
  2254.     IF(MFID(2).EQ.IPAG)GOTO 851
  2255.     GOTO 854
  2256. 850    CONTINUE
  2257. C PAGE 1 IS THE ONE WE NEED.
  2258.     MFLAST=1
  2259.     MFBASE=0
  2260.     GOTO 1400
  2261. 851    CONTINUE
  2262. C NEED SECOND PAGE
  2263.     MFLAST=2
  2264.     MFBASE=1024
  2265. C BASE IS HASFWAY ALONG FILE...
  2266.     GOTO 1400
  2267. 854    CONTINUE
  2268. C HERE FIGURE OUT WHICH BUFFER IS TO BE REPLACED.
  2269.     MFLAST=3-MFLAST
  2270.     MFBASE=1024-MFBASE
  2271. C SIMILAR LOGIC SAYS MFBAS4E IS EITHER 0 OR 1024. INITIALIZED IN
  2272. C WSSET TO 0.
  2273. C NOTE THAT IF MFLAST=1,MBFN=1 AND IF MFLAST=2,NEW MFLAST=1
  2274. C THIS GIVES BUFFER TO REPLACE... (LRU)
  2275. C
  2276. C IF MFLAST=2 REPLACE BUFFER 1, ELSE REPLACE BUFFER 0
  2277. C NOW MFID HAS MEMORY PAGE CURRENTLY PRESENT, IPAG IS DESIRED ONE FOR THIS
  2278. C FORMULA. NOTE WHILE WE USE A HASHCODE TO SEARCH FOR FORMULAS, ALL SEGMENTS
  2279. C OF A FORMULA MUST BE PLACED IN ONE MEMORY PAGE. THUS, IT IS POSSIBLE TO
  2280. C RUN OUT OF SPACE IF THE MEMORY BUFFER GETS TOO SMALL. CURRENT HASH
  2281. C CODE TRIES TO SPREAD THE FORMULAS OUT, BUT BIG MEMORY BUFFERS ALWAYS
  2282. C WIN.....
  2283.     IF(LPGMXF.LE.32)GOTO 1400
  2284. C    IF(LPGMXF.LE.(2048/64))GOTO 1400
  2285. C WRITE WHATEVER'S IN MEMORY TO FILE AND READ THE NEW PAGE IN.
  2286. C    IBF=32
  2287. CC    IBF=(1024+31)/32
  2288. C    IF(IBF.LT.1)IBF=1
  2289. C IBF IS BLK FACTOR FOR ONE WRITE
  2290. C WRITE 512 BYTES AT A TIME.
  2291.     L=1+MFBASE
  2292.     LLBK=(MFID(MFLAST)-1)*IBF+1
  2293.     LHBK=MFID(MFLAST)*IBF
  2294.     DO 1170 N=LLBK,LHBK
  2295.     IF(MFMOD(MFLAST).EQ.0)GOTO 1170
  2296.     LL=L+31
  2297.     WRITE(7,REC=N,ERR=1170)((IFID(K,KK),K=1,8),KK=L,LL)
  2298.     L=L+32
  2299. 1170    CONTINUE
  2300. C NOW READ IN THE DATA
  2301.     MFMOD(MFLAST)=0
  2302. C MARK PAGE UNTOUCHED. READING DOES NOT ALTER DATA SO NO NEED
  2303. C TO WRITE OUT UNLESS MODIFIED.
  2304.     MFID(MFLAST)=IPAG
  2305.     L=1+MFBASE
  2306.     LLBK=(MFID(MFLAST)-1)*IBF+1
  2307.     LHBK=MFID(MFLAST)*IBF
  2308.     DO 1171 N=LLBK,LHBK
  2309.     LL=L+31
  2310.     READ(7,REC=N,ERR=1171)((IFID(K,KK),K=1,8),KK=L,LL)
  2311.     L=L+32
  2312. 1171    CONTINUE
  2313. C DATA ALL SHOULD BE THERE NOW... OK, GO AHEAD.
  2314. 1400    CONTINUE
  2315. C NOW HAVE THE DESIRED MEMORY PAGE; READ THE FORMULA INTO ARRAY
  2316. C BUFFER.
  2317.     IARSUB=1
  2318. C FOR SIMPLICITY FORGET THE HASHCODE WITHIN MEMORY BUFFERS, JUST SEARCH
  2319. C FROM START...
  2320.     IFLAG=0
  2321.     IFMT=0
  2322.     DO 2500 NN=1,1024
  2323. c    N=MOD((NN+JHASH-1),1024)
  2324.     N=MOD((NN+JHASH),1024)
  2325.     N=N+1+MFBASE
  2326. C    N=IMASK((NN+JHASH-1),1023)+1+MFBASE
  2327.     KKKKK=IFID(1,N)
  2328.     IF(NN.GT.2.AND.KKKKK.EQ.-1)GOTO 2505
  2329.     IF(KKKKK.NE.NREC)GOTO 2500
  2330.     IFLAG=ICHAR(LFID(3,N))
  2331.     IF(IFMT.EQ.0)IFMT=ICHAR(LFID(4,N))
  2332.     DO 2502 K=1,12
  2333.     LI=LFID(K+4,N)
  2334. C COPY FORMULA TEXT INTO ARRAY. END ON NULLS...
  2335.     IF(ICHAR(LI).LE.0)GOTO 2505
  2336.     ARRAY(IARSUB)=LI
  2337. c null out following characters since -1's could be misinterpreted as data
  2338.     array(iarsub+1)=0
  2339.     array(iarsub+2)=0
  2340.     IARSUB=IARSUB+1
  2341. 2502    CONTINUE
  2342.     IF(IFLAG.EQ.1.OR.IFLAG.EQ.3)GOTO 2505
  2343. 2500    CONTINUE
  2344. 2505    CONTINUE
  2345. C GET FORMAT NOW...
  2346.     IF(IFMT.LE.0)RETURN
  2347.     DO 2510 N=1,9
  2348. 2510    ARRAY(119+N)=FMTDAT(N,IFMT)
  2349.     GOTO 5000
  2350. 2000    CONTINUE
  2351. C WRITE
  2352. C NOW SET INIT'D BIT; WRITE ARRAY ELEMENT OUT.
  2353. C FIRST FIND FORMAT AREA OR SET IT UP.
  2354.     IFMT=0
  2355.     LFF=0
  2356. C FAKE OUT THE SAVING OF FVLD INFO IN THIS ARRAY TOO.
  2357. C THIS IS INCOMPLETE AND NO LITTLE OF A KLUDGE BUT THE CODE WILL
  2358. C GENERALLY SET THEM TOGETHER, AND THIS GUARANTEES THAT IF
  2359. C FURTHER SETS TRY TO SET FVLD TO ARRAY(119), THEY'LL WORK AS
  2360. C THEY SHOULD.
  2361. C HERE SET MAX ARRAY ELEMENTS USED
  2362. C EXPECT (ID2-1)*60+ID1
  2363. C ID1 IS 60 DIM, ID2 IS 301 DIM
  2364. C    NRC2(2)=0
  2365. C    NRC2(1)=NREC
  2366. C JUST EQUATE NRC TO NREC
  2367. C ALLOW LATER FOR OVER 32768 ELEMENTS... NO NEED TO JUST YET
  2368. C WHEN WE DO, REPLACE NRC2 STUFF (WHOSE PURPOSE IS TO AVOID
  2369. C SIGN EXTENSIONS).
  2370. C NEXT KEEP TRACK OF LOWER RIGHT CORNER OF AREA IN USE.
  2371.     NRC=NREC-1
  2372.     IRUSED=MOD(NRC,60)+1
  2373.     ICUSED=((NRC-IRUSED+1)/60)+1
  2374.     IF(ICUSED.GT.RCLACT)RCLACT=ICUSED
  2375.     IF(IRUSED.GT.RRWACT)RRWACT=IRUSED
  2376. C SET RRWACT, RCLACT
  2377.     IF(ICHAR(ARRAY(119)).NE.0)CALL FVLDST(NREC,1,ARRAY(119))
  2378.     DO 2011 N=1,76
  2379.     IF(ICHAR(FMTDAT(1,N)).LE.0.AND.LFF.EQ.0)LFF=N
  2380. C SAVE FIRST FREE FORMAT AREA IN CASE THIS IS A NEW FORMAT...
  2381.     DO 2010 M=1,9
  2382.     IF(ARRAY(M+119).NE.FMTDAT(M,N))GOTO 2011
  2383. 2010    CONTINUE
  2384.     IFMT=N
  2385.     GOTO 2012
  2386. 2011    CONTINUE
  2387. C ON FALL THROUGH, WE FOUND NOTHING FOR IT...
  2388. C USE HIS FORMAT UNLESS WE HAVE NO ROOM, IN WHICH CASE USE LAST AREA
  2389.     IF(LFF.EQ.0)LFF=76
  2390.     IFMT=LFF
  2391.     DO 2013 N=1,9
  2392. 2013    FMTDAT(N,LFF)=ARRAY(119+N)
  2393. C SAVE FORMAT DATA WE NOW POINT TO...
  2394. 2012    CONTINUE
  2395. C NOW THE HARDER PART... MUST WRITE THE ARRAY'S FORMULA TOO...
  2396. C    IPM=(LPGMXF*64/2048)+1
  2397.     IBF=32
  2398. C    IBF=(2048+31)/32/2
  2399. C    LLL=(LPGMXF*2)/IBF
  2400. C    IPM=LLL
  2401.     IPM=LPGMXF/16
  2402. C IPM = NO. PAGES IN FILE. LPGMXF/(LENGTH OF ONE MEM BUFFER IN K).
  2403.     IF(IPM.LT.2)IPM=2
  2404. C FORCE IPM (MAX MEM PAGE) TO BE IN VALID RANGE
  2405.     IHASH=NREC
  2406. C    JHASH=IMASK(IHASH,1023)
  2407.     JHASH=MOD(IHASH,1024)
  2408.     IF(LPGMOD.NE.0)GOTO 5307
  2409.     IPAG=(IHASH/1024)+1
  2410.     IPAG=MOD(IPAG,IPM)+1
  2411.     GOTO 5308
  2412. 5307    CONTINUE
  2413. C SPEED OPTIMAL PACK
  2414.     FPG=FLOAT(IHASH)*FLOAT(IPM)/FLOAT(LPGMOD)
  2415.     IPAG=FPG
  2416.     IPAG=MOD(IPAG,IPM)
  2417.     IPAG=IPAG+1
  2418. C    IPAG=1+(IHASH*IPM)/18060
  2419. 5308    CONTINUE
  2420. C ***
  2421. C DETERMINE FIRST THAT NEITHER PAGE NUMBER IS ZERO.
  2422.     IF(IPAG.EQ.MFID(1).OR.IPAG.EQ.MFID(2))GOTO 953
  2423.     IF(MFID(1).NE.0)GOTO 952
  2424.     MFID(1)=IPAG
  2425.     GOTO 953
  2426. 952    IF(MFID(2).EQ.0)MFID(2)=IPAG
  2427. 953    CONTINUE
  2428.     IF(MFID(2).EQ.IPAG)GOTO 951
  2429.     IF(MFID(1).NE.IPAG) GOTO 954
  2430. 950    CONTINUE
  2431. C PAGE 1 IS THE ONE WE NEED.
  2432.     MFLAST=1
  2433.     MFBASE=0
  2434.     GOTO 2400
  2435. 951    CONTINUE
  2436. C NEED SECOND PAGE
  2437.     MFLAST=2
  2438.     MFBASE=1024
  2439. C BASE IS HASFWAY ALONG FILE...
  2440.     GOTO 2400
  2441. 954    CONTINUE
  2442. C HERE FIGURE OUT WHICH BUFFER IS TO BE REPLACED.
  2443.     MFLAST=3-MFLAST
  2444.     MFBASE=1024-MFBASE
  2445. C ***
  2446. C NOW MFID HAS MEMORY PAGE CURRENTLY PRESENT, IPAG IS DESIRED ONE FOR THIS
  2447. C FORMULA. NOTE WHILE WE USE A HASHCODE TO SEARCH FOR FORMULAS, ALL SEGMENTS
  2448. C OF A FORMULA MUST BE PLACED IN ONE MEMORY PAGE. THUS, IT IS POSSIBLE TO
  2449. C RUN OUT OF SPACE IF THE MEMORY BUFFER GETS TOO SMALL. CURRENT HASH
  2450. C CODE TRIES TO SPREAD THE FORMULAS OUT, BUT BIG MEMORY BUFFERS ALWAYS
  2451. C WIN.....
  2452.     IF(LPGMXF.LE.32)GOTO 2400
  2453. C WRITE WHATEVER'S IN MEMORY TO FILE AND READ THE NEW PAGE IN.
  2454. C    IBF=(1024+31)/32
  2455. C    IBF=32
  2456. C IBF IS BLK FACTOR
  2457.     L=1+MFBASE
  2458.     LLBK=(MFID(MFLAST)-1)*IBF+1
  2459.     LHBK=MFID(MFLAST)*IBF
  2460.     DO 2170 N=LLBK,LHBK
  2461.     IF(MFMOD(MFLAST).EQ.0)GOTO 2170
  2462.     LL=L+31
  2463.     WRITE(7,REC=N,ERR=2170)((IFID(K,KK),K=1,8),KK=L,LL)
  2464.     L=L+32
  2465. 2170    CONTINUE
  2466. C NOW READ IN THE DATA
  2467. C MARK NEW PAGE TOUCHED SINCE WE WILL DO SO HERE
  2468. C    MFMOD=1
  2469.     MFID(MFLAST)=IPAG
  2470.     L=1+MFBASE
  2471.     LLBK=(MFID(MFLAST)-1)*IBF+1
  2472.     LHBK=MFID(MFLAST)*IBF
  2473.     DO 2171 N=LLBK,LHBK
  2474.     LL=L+31
  2475.     READ(7,REC=N,ERR=2171)((IFID(K,KK),K=1,8),KK=L,LL)
  2476.     L=L+32
  2477. 2171    CONTINUE
  2478. C DATA ALL SHOULD BE THERE NOW... OK, GO AHEAD.
  2479. 2400    CONTINUE
  2480. C NOW HAVE THE DESIRED MEMORY PAGE; READ THE FORMULA INTO ARRAY
  2481. C BUFFER.
  2482.     MFMOD(MFLAST)=1
  2483.     IARSUB=1
  2484. C FOR SIMPLICITY FORGET THE HASHCODE WITHIN MEMORY BUFFERS, JUST SEARCH
  2485. C FROM START...
  2486. C OMIT THE ZEROING WHEN READING IN FROM FILE EXCEPT IN /MERGE MODE
  2487.     IF(NXINI.NE.0)GOTO 6233
  2488.     DO 1490 NN=1,1024
  2489.     N=MOD((NN+JHASH),1024)+1+MFBASE
  2490. C    N=IMASK((NN+JHASH),1023)+1+MFBASE
  2491.     KKKKK=IFID(1,N)
  2492.     IF(NN.GT.2.AND.KKKKK.EQ.-1)GOTO 6233
  2493. C SKIP ZEROING ONCE WE ENCOUNTER A VIRGIN CELL SINCE WE WOULD ALWAYS
  2494. C CLEAR TO NONVIRGIN STATUS AFTERWARDS.
  2495.     IF(KKKKK.NE.NREC)GOTO 1490
  2496. C ZERO OLD RECORDS OF THIS ONE...
  2497.     NCEL=NCEL-1
  2498.     IF(NCEL.LT.0)NCEL=0
  2499.     DO 1498 KK=1,8
  2500. 1498    IFID(KK,N)=0
  2501. 1490    CONTINUE
  2502. 6233    CONTINUE
  2503.     IFLAG=0
  2504.     DO 1500 NN=1,1024
  2505.     N=MOD((NN+JHASH),1024)+1+MFBASE
  2506. C    N=IMASK((NN+JHASH),1023)+1+MFBASE
  2507.     KKKKK=IFID(1,N)
  2508.     IF(KKKKK.NE.-1.AND.KKKKK.NE.0
  2509.      1     .AND.KKKKK.NE.NREC)GOTO 1500
  2510. C FOUND A NULL NODE...
  2511. C FILL IT IN NOW.
  2512.     NCEL=NCEL+1
  2513.     IFID(1,N)=NREC
  2514.     IFLAG=1
  2515.     LFID(4,N)=CHAR(IFMT)
  2516.     LFID(3,N)=CHAR(IFLAG)
  2517. c zero new elements to ensure no extra -1's get handled as
  2518. c data. Important because they could be mistaken for cell codings now.
  2519.     do 4502 k=1,12
  2520. 4502    lfid(k+4,n)=CHAR(0)
  2521.     DO 1502 K=1,12
  2522.     LI=ARRAY(IARSUB)
  2523.     IF(ICHAR(LI).LE.0)GOTO 1505
  2524. C CHOP IT OFF AT 109 ALSO...
  2525.     IF(IARSUB.GT.109)GOTO 1560
  2526.     LFID(K+4,N)=LI
  2527.     IARSUB=IARSUB+1
  2528. 1502    CONTINUE
  2529. C NONTERMINAL COPY...NEED ANOTHER CELL. FIRST TEST FOR EXACT FIT,
  2530. C HOWEVER.
  2531.     IF(ICHAR(ARRAY(IARSUB)).LE.0)GOTO 1560
  2532.     IFLAG=2
  2533.     LFID(3,N)=CHAR(IFLAG)
  2534. C NOW GO GET MORE SPACE FOR NEXT NODE.
  2535. C NOTE IT COULD RUN OUT, BUT JUST PUNT THAT.
  2536.     GOTO 1500
  2537. 1560    CONTINUE
  2538.     IF(IFLAG.EQ.1)IFLAG=3
  2539.     LFID(3,N)=CHAR(IFLAG)
  2540. C SETS UP EITHER 1 OR 3 FOR TERMINAL NODES
  2541.     GOTO 1505
  2542. C ESCAPE FROM LOOP ON ENDS...
  2543. 1500    CONTINUE
  2544. C HERE WE RAN OUT OF ROOM. TOO BAD...CAN'T REALLY HELP IT OR
  2545. C DO MUCH. JUST FORGET IT.
  2546. C HOWEVER, PRINT A MESSAGE ON SCREEN AT LEAST...
  2547.     CALL UVT100(1,1,1)
  2548.     CALL SWRT('Formula file overflowed. Try larger file.',41)
  2549. 1505    CONTINUE
  2550. C DONE NOW.
  2551.     GOTO 5000
  2552. 3000    CONTINUE
  2553. C OPEN (CLR BITMAP)
  2554.     MFID(1)=0
  2555.     MFID(2)=0
  2556.     MFBASE=0
  2557.     MFLAST=1
  2558.     GOTO 5000
  2559. 4000    CONTINUE
  2560. C CLOSE (CLR BITMAP)
  2561.     CLOSE(7,STATUS='DELETE')
  2562.     MFBASE=0
  2563.     MFLAST=1
  2564.     MFID(1)=0
  2565.     MFID(2)=0
  2566. 5000    RETURN
  2567.     END
  2568. c -h- xvblgt.f40    Fri Aug 22 13:45:23 1986    
  2569.         SUBROUTINE XVBLGT(ID1,ID2,XX)
  2570. C
  2571. C XVBLGT - LOAD 8 BYTES GIVEN DIMENSIONS FOR GETTING THEM
  2572. C 2 DIM ARRAY, DIM'D (60,301)
  2573.         InTeGer*4 ID1,ID2
  2574.         REAL*8 XX
  2575.     InTeGer*4 TYPE(1,1),VLEN(9)
  2576.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1),VT(8)
  2577.     REAL*8 XXV(1,1),XVT
  2578.     EQUIVALENCE(XVT,VT(1))
  2579.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  2580.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  2581.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  2582.     COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
  2583. C ***<<<< RDD COMMON START >>>***
  2584.     InTeGer*4 RRWACT,RCLACT
  2585. C    COMMON/RCLACT/RRWACT,RCLACT
  2586.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2587.      1  IDOL7,IDOL8
  2588. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2589. C     1  IDOL7,IDOL8
  2590.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2591. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2592.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2593. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2594. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2595. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2596.     InTeGer*4 KLVL
  2597. C    COMMON/KLVL/KLVL
  2598.     InTeGer*4 IOLVL,IGOLD
  2599. C    COMMON/IOLVL/IOLVL
  2600. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2601. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2602.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2603.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2604.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2605. C ***<<< RDD COMMON END >>>***
  2606. CCC        InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2607. CCC        COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2608. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2609. C NEXT BITMAPS IMPLEMENT FVLD
  2610.         CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
  2611.     CHARACTER*1 FVXX(6792)
  2612.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
  2613.     EQUIVALENCE (FV4(1),FVXX(4529))
  2614.         Common/FVLDM/FVXX
  2615. c        COMMON/FVLDM/FV1,FV2,FV4
  2616.         CHARACTER*1 LBITS(8)
  2617.         COMMON/BITS/LBITS
  2618. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  2619. C TYPES OF AC'S STORAGE:
  2620.         CHARACTER*1 ITYP(2264),LWK
  2621.         InTeGer*4 IATYP(27)
  2622.     INTEGER*2 LL(4)
  2623.     REAL*8 XA
  2624.     EQUIVALENCE(LL(1),XA)
  2625.         COMMON/TYP/IATYP,ITYP
  2626. C ***<<< NULETC COMMON START >>>***
  2627.     InTeGer*4 ICREF,IRREF
  2628. C    COMMON/MIRROR/ICREF,IRREF
  2629.     InTeGer*4 MODPUB,LIMODE
  2630. C    COMMON/MODPUB/MODPUB,LIMODE
  2631.     InTeGer*4 KLKC,KLKR
  2632.     REAL*8 AACP,AACQ
  2633. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  2634.     InTeGer*4 NCEL,NXINI
  2635. C    COMMON/NCEL/NCEL,NXINI
  2636.     CHARACTER*1 NAMARY(20,301)
  2637. C    COMMON/NMNMNM/NAMARY
  2638.     InTeGer*4 NULAST,LFVD
  2639. C    COMMON/NULXXX/NULAST,LFVD
  2640.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  2641.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  2642. C ***<<< NULETC COMMON END >>>***
  2643. CCC    InTeGer*4 ICREF,IRREF
  2644. CCC    COMMON/MIRROR/ICREF,IRREF
  2645.         InTeGer*2 LVALBF(5,800)
  2646.         InTeGer*4 MPAG(2),MPMOD(2)
  2647.         COMMON/VB/MPAG,LVALBF,MPMOD
  2648. C
  2649. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  2650. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  2651. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  2652. C AREAS WITH DATA.
  2653. C ***<<< KLSTO COMMON START >>>***
  2654.     InTeGer*4 DLFG
  2655. C    COMMON/DLFG/DLFG
  2656.     InTeGer*4 KDRW,KDCL
  2657. C    COMMON/DOT/KDRW,KDCL
  2658.     InTeGer*4 DTRENA
  2659. C    COMMON/DTRCMN/DTRENA
  2660.     REAL*8 EP,PV,FV
  2661.     DIMENSION EP(20)
  2662.     INTEGER*4 KIRR
  2663. C    COMMON/ERNPER/EP,PV,FV,KIRR
  2664.     InTeGer*4 LASTOP
  2665. C    COMMON/ERROR/LASTOP
  2666.     CHARACTER*1 FMTDAT(9,76)
  2667. C    COMMON/FMTBFR/FMTDAT
  2668.     CHARACTER*1 EDNAM(16)
  2669. C    COMMON/EDNAM/EDNAM
  2670.     InTeGer*4 MFID(2),MFMOD(2)
  2671. C    COMMON/FRM/MFID,MFMOD
  2672.     InTeGer*4 JMVFG,JMVOLD
  2673. C    COMMON/FUBAR/JMVFG,JMVOLD
  2674.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  2675.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  2676. C ***<<< KLSTO COMMON END >>>***
  2677. CCC        CHARACTER*1 FMTDAT(9,76)
  2678. CCC        COMMON/FMTBFR/FMTDAT
  2679.     IF(ID1.GT.27.OR.ID2.GT.1)GOTO 7800
  2680. C AN ACCUMULATOR. GET IT.
  2681.     DO 7801 IV=1,8
  2682. 7801    VT(IV)=AVBLS(IV,ID1)
  2683.     XX=XVT
  2684.     RETURN
  2685. 7800    CONTINUE
  2686. C FILTER OUT TOO-LARGE ID1, ID2 THAT ARE "REFLECTED" UP
  2687. C        ID=(ID2-1)*60+ID1
  2688.     CALL REFLEC(ID2,ID1,ID)
  2689.         XX=0.
  2690. C NOTE THAT HERE IF FVLD IS 0, THIS MEANS RESULT IS 0 REGARDLESS OF
  2691. C OTHER STUFF...RETURN 0 IMMEDIATELY.
  2692. C NOTE TRICK CALL WHICH SIGNALS ANY INITIALIZATION GETS EVALUATED.
  2693.     CALL FVLDGT(ID,0,LWK)
  2694.     IF(ICHAR(LWK).EQ.0)RETURN
  2695. C SET UP HASH CODE NOW FOR THE WAY WE NEED...
  2696.     IBF=8
  2697. C    IBF=(800+49)/50/2
  2698. C    IF(IBF.LT.1)IBF=1
  2699. C
  2700. C    LLL=(IPGMAX*2)/IBF
  2701.     LLL=IPGMAX/4
  2702. C WAS IPGMAX*2
  2703.     IPM=LLL
  2704.     IF(IPM.LE.2)IPM=2
  2705.     IHASH=ID
  2706.         JHASH=MOD(IHASH,400)+1
  2707.     IF(IPGMOD.NE.0)GOTO 3402
  2708.         IPAG=(IHASH/400)+1
  2709.         IPAG=MOD(IPAG,IPM)+1
  2710.     GOTO 3403
  2711. 3402    CONTINUE
  2712. C SPEED-OPTIMIZING PACKING
  2713.     FPG=IPGMOD
  2714. C    IF(FPG.LE.0)FPG=FPG+65536.
  2715.     FPG=FLOAT(IHASH)*FLOAT(IPM)/FPG
  2716.     IPAG=FPG
  2717.     IPAG=MOD(IPAG,IPM)
  2718.     IPAG=IPAG+1
  2719. C    IPAG=1+(IHASH*IPM)/18060
  2720. 3403    CONTINUE
  2721. C        IF(IPAG.LE.0)IPAG=1
  2722. C TAKE CARE OF EMPTY INITIAL BUFFER...
  2723.     IF(IPAG.EQ.MPAG(1).OR.IPAG.EQ.MPAG(2))GOTO 851
  2724.     IF(MPAG(1).NE.0)GOTO 850
  2725.     MPAG(1)=IPAG
  2726.     GOTO 851
  2727. 850    IF(MPAG(2).EQ.0)MPAG(2)=IPAG
  2728. 851    CONTINUE
  2729.     IF(MPAG(1).EQ.IPAG)GOTO 852
  2730.     IF(MPAG(2).NE.IPAG)GOTO 853
  2731. C MPAG(2)=IPAG
  2732.     MVLAST=2
  2733.     MVBASE=400
  2734.     GOTO 1000
  2735. 852    CONTINUE
  2736.     MVLAST=1
  2737.     MVBASE=0
  2738.     GOTO 1000
  2739. 853    CONTINUE
  2740. C SWITCH BUFFER USED LEAST RECENTLY
  2741.     MVLAST=3-MVLAST
  2742.     MVBASE=400-MVBASE
  2743. C
  2744. C THE ABOVE ACCOUNTS FOR MEMORY FREE... WE TREAT FILE AS IPM
  2745. C "PAGES" THE SIZE OF THE MEMORY AREA EACH. THIS MAKES IT RELATIVELY
  2746. C EASY TO ALTER THE PROGRAM TO HANDLE MORE MEMORY TO THE EXTENT THE
  2747. C COMPILER AND MACHINE ALLOW.
  2748.     IF(IPGMAX.LE.8)GOTO 1000
  2749. C IF HERE, WE NEED A PAGE NOT IN MEMORY. SWAP THE CURRENT MEMORY PAGE
  2750. C TO DISK AND BRING IN THE ONE DESIRED.
  2751. C FILES ARE OPENED ALREADY HERE... USE LUN 9 HERE.
  2752.         IRCLO=(MPAG(MVLAST)-1)*IBF+1
  2753.         IRCHI=MPAG(MVLAST)*IBF
  2754.         L=1+MVBASE
  2755.         DO 500 N=IRCLO,IRCHI
  2756.     IF(MPMOD(MVLAST).EQ.0)GOTO 500
  2757.         LLL=L+49
  2758.         WRITE(13,REC=N,ERR=500)((LVALBF(KKK,K),KKK=1,5),K=L,LLL)
  2759.         L=L+50
  2760. 500     CONTINUE
  2761.     MPMOD(MVLAST)=0
  2762. C MARK NEW PAGE UNMODIFIED IN THIS READ PROGRAM
  2763.         MPAG(MVLAST)=IPAG
  2764. C NOW READ IN THE DESIRED RECORD, HAVING SET THE DESIRED IN-MEMORY FLAG
  2765.         IRCLO=(MPAG(MVLAST)-1)*IBF+1
  2766.         IRCHI=MPAG(MVLAST)*IBF
  2767.         L=1+MVBASE
  2768.         DO 501 N=IRCLO,IRCHI
  2769.         LLL=L+49
  2770.         READ(13,REC=N,END=501,ERR=501)((LVALBF(KKK,K),KKK=1,5),K=L,LLL)
  2771.         L=L+50
  2772. 501     CONTINUE
  2773. 1000    CONTINUE
  2774. C NOW THE PAGE NEEDED IS IN MEMORY (OR MAY HAVE BEEN ALL ALONG)
  2775. C SET THE VALUE INTO IT AS REQUIRED...
  2776. C NOW START LOOKING AT HASH ADDRESS FOR VARIABLE...LINEAR SEARCH AFTERWARDS
  2777.         IH1=JHASH-1
  2778.         DO 2 MMN=JHASH,400
  2779.     N=MMN+MVBASE
  2780.     NN=N
  2781. C SKIP OUT IF WE SEE VIRGIN CELLS, LEAVING XX=0.
  2782.     KKKKK=LVALBF(1,N)
  2783.     IF(KKKKK.EQ.-1)GOTO 3332
  2784.         IF(KKKKK.EQ.ID)GOTO 4
  2785. 2       CONTINUE
  2786.         IF(IH1.LT.1)RETURN
  2787.         DO 3 MMN=1,IH1
  2788.     N=MMN+MVBASE
  2789. C LOOK BEFORE THE HASHCODE IF NO FREE CELLS AFTER IT.
  2790.     NN=N
  2791.     KKKKK=LVALBF(1,N)
  2792.     IF(KKKKK.EQ.-1)GOTO 3332
  2793.         IF(KKKKK.EQ.ID)GOTO 4
  2794. 3       CONTINUE
  2795. 3332    XX=0.
  2796.         RETURN
  2797. C RETURN IF CAN'T FIND VALUE...TOO BAD
  2798. 4       CONTINUE
  2799. C GET VALUE AS 4 16-BIT WORDS
  2800.         DO 5 M=1,4
  2801. 5       LL(M)=LVALBF(M+1,NN)
  2802.         XX=XA
  2803.         RETURN
  2804.         END
  2805. c -h- xvblst.f40    Fri Aug 22 13:45:23 1986    
  2806.         SUBROUTINE XVBLST(ID1,ID2,XX)
  2807. C
  2808. C XVBLST - STORE 8 BYTES IN VARIABLES ARRAY
  2809. C GIVEN DIMENSIONS FOR LOCATING THEM
  2810.         InTeGer*4 ID1,ID2
  2811.     InTeGer*4 TYPE(1,1),VLEN(9)
  2812.     CHARACTER*1 AVBLS(20,27),VBLS(8,1,1),VT(8)
  2813.     REAL*8 XVT
  2814.     EQUIVALENCE(VT(1),XVT)
  2815.     REAL*8 XXV(1,1)
  2816.     EQUIVALENCE(XXV(1,1),VBLS(1,1,1))
  2817.     COMMON/V/TYPE,AVBLS,VBLS,VLEN
  2818.         REAL*8 XX
  2819. C ***<<<< RDD COMMON START >>>***
  2820.     InTeGer*4 RRWACT,RCLACT
  2821. C    COMMON/RCLACT/RRWACT,RCLACT
  2822.     InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
  2823.      1  IDOL7,IDOL8
  2824. C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
  2825. C     1  IDOL7,IDOL8
  2826.     InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
  2827. C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
  2828.     InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2829. C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2830. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2831. C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
  2832.     InTeGer*4 KLVL
  2833. C    COMMON/KLVL/KLVL
  2834.     InTeGer*4 IOLVL,IGOLD
  2835. C    COMMON/IOLVL/IOLVL
  2836. C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
  2837. C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
  2838.     COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
  2839.      1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
  2840.      2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
  2841. C ***<<< RDD COMMON END >>>***
  2842. CCC        InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2843. CCC        COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
  2844. C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
  2845. C NEXT BITMAPS IMPLEMENT FVLD
  2846.         CHARACTER*1 FV1(2264),FV2(2264),FV4(2264)
  2847.     CHARACTER*1 FVXX(6792)
  2848.     EQUIVALENCE (FV1(1),FVXX(1)),(FV2(1),FVXX(2265))
  2849.     EQUIVALENCE (FV4(1),FVXX(4529))
  2850.         Common/FVLDM/FVXX
  2851. c        COMMON/FVLDM/FV1,FV2,FV4
  2852.         CHARACTER*1 LBITS(8)
  2853.         COMMON/BITS/LBITS
  2854. C THE FOLLOWING BITMAP IS FOR TYPE ARRAY, AND INTEGER ARRAY IS FOR
  2855. C TYPES OF AC'S STORAGE:
  2856.         CHARACTER*1 ITYP(2264)
  2857. C ***<<< NULETC COMMON START >>>***
  2858.     InTeGer*4 ICREF,IRREF
  2859. C    COMMON/MIRROR/ICREF,IRREF
  2860.     InTeGer*4 MODPUB,LIMODE
  2861. C    COMMON/MODPUB/MODPUB,LIMODE
  2862.     InTeGer*4 KLKC,KLKR
  2863.     REAL*8 AACP,AACQ
  2864. C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
  2865.     InTeGer*4 NCEL,NXINI
  2866. C    COMMON/NCEL/NCEL,NXINI
  2867.     CHARACTER*1 NAMARY(20,301)
  2868. C    COMMON/NMNMNM/NAMARY
  2869.     InTeGer*4 NULAST,LFVD
  2870. C    COMMON/NULXXX/NULAST,LFVD
  2871.     COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
  2872.      1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
  2873. C ***<<< NULETC COMMON END >>>***
  2874. CCC    InTeGer*4 ICREF,IRREF
  2875. CCC    COMMON/MIRROR/ICREF,IRREF
  2876.         InTeGer*4 IATYP(27)
  2877.         COMMON/TYP/IATYP,ITYP
  2878. C
  2879. C NEXT ARE BUFFERS FOR HOLDING VALUES, AND MEMORY OCCUPANCY WORDS
  2880. C FOR EACH GIVING THE BLK # IN USE FOR THESE TABLES
  2881. C FORMAT BLOCK (ONE ONLY, 512 BYTES, BUT ORGANIZED AS 76 FORMAT
  2882. C AREAS WITH DATA.
  2883.         CHARACTER*1 LLTST
  2884. C ***<<< KLSTO COMMON START >>>***
  2885.     InTeGer*4 DLFG
  2886. C    COMMON/DLFG/DLFG
  2887.     InTeGer*4 KDRW,KDCL
  2888. C    COMMON/DOT/KDRW,KDCL
  2889.     InTeGer*4 DTRENA
  2890. C    COMMON/DTRCMN/DTRENA
  2891.     REAL*8 EP,PV,FV
  2892.     DIMENSION EP(20)
  2893.     INTEGER*4 KIRR
  2894. C    COMMON/ERNPER/EP,PV,FV,KIRR
  2895.     InTeGer*4 LASTOP
  2896. C    COMMON/ERROR/LASTOP
  2897.     CHARACTER*1 FMTDAT(9,76)
  2898. C    COMMON/FMTBFR/FMTDAT
  2899.     CHARACTER*1 EDNAM(16)
  2900. C    COMMON/EDNAM/EDNAM
  2901.     InTeGer*4 MFID(2),MFMOD(2)
  2902. C    COMMON/FRM/MFID,MFMOD
  2903.     InTeGer*4 JMVFG,JMVOLD
  2904. C    COMMON/FUBAR/JMVFG,JMVOLD
  2905.     COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
  2906.      1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
  2907. C ***<<< KLSTO COMMON END >>>***
  2908. CCC        COMMON/FMTBFR/FMTDAT
  2909.         InTeGer*2 LVALBF(5,800)
  2910.         InTeGer*4 MPAG(2),MPMOD(2)
  2911.         COMMON/VB/MPAG,LVALBF,MPMOD
  2912.     InTeGer*4 MFLAST,MFBASE,MVLAST,MVBASE
  2913.     COMMON/VBCTL/MFLAST,MFBASE,MVLAST,MVBASE
  2914.         InTeGer*2 LL(4)
  2915.         REAL*8 XA
  2916.         EQUIVALENCE(XA,LL(1))
  2917. CCC    InTeGer*4 NCEL,NXINI
  2918. CCC    COMMON/NCEL/NCEL,NXINI
  2919.     IF(ID1.GT.27.OR.ID2.GT.1)GOTO 7800
  2920. C AN ACCUMULATOR. SET IT.
  2921.     XVT=XX
  2922.     DO 7801 IV=1,8
  2923. 7801    AVBLS(IV,ID1)=VT(IV)
  2924.     RETURN
  2925. 7800    CONTINUE
  2926. C        ID=(ID2-1)*60+ID1
  2927.     CALL REFLEC(ID2,ID1,ID)
  2928. C SET UP HASH CODE NOW FOR THE WAY WE NEED...
  2929. C       IPM=(IPGMAX*200/800)
  2930.     IF(ID.LE.0)RETURN
  2931. C CALL FVLDGT TO TELL IF ANYTHING IS SET FOR THE CELL...
  2932.     CALL FVLDGT(ID1,ID2,LLTST)
  2933.     IF(ICHAR(LLTST).NE.0)GOTO 3419
  2934.     CALL FVLDST(ID1,ID2,Char(252))
  2935. c 252 = -4 to 8 bits
  2936. C TRICK ... SET UP SIGN BIT IN FVLD SO XVBLGT CAN FIND OUT IF
  2937. C VARIABLE HAS EVER BEEN WRITTEN AND EXIT IF NOT. INDEPENDENT OF
  2938. C USUAL SETTING OF FVLD SINCE IT USES "SIGN" BIT ONLY.
  2939. 3419    CONTINUE
  2940.     IBF=8
  2941. C    IBF=(800+49)/50/2
  2942. C    IF(IBF.LT.1)IBF=1
  2943.     LLL=IPGMAX/4
  2944. C 4000 BYTES PER BUFFER (400 CELLS AT 10 PER CELL)
  2945. C    LLL=(IPGMAX*2)/IBF
  2946. C WAS IPGMAX*2
  2947.     IPM=LLL
  2948.     IF(IPM.LE.2)IPM=2
  2949.     IHASH=ID
  2950.         JHASH=MOD(IHASH,400)+1
  2951.     IF(IPGMOD.NE.0)GOTO 3400
  2952. C SPACE-OPTIMIZING PACKING
  2953.         IPAG=(IHASH/400)+1
  2954.         IPAG=MOD(IPAG,IPM)+1
  2955.     GOTO 3401
  2956. 3400    CONTINUE
  2957. C SPEED-OPTIMIZING PACKING
  2958.     FPG=FLOAT(IPGMOD)
  2959. C    IF(FPG.LE.0.)FPG=FPG+65536.
  2960.     FPG=FLOAT(IHASH)*FLOAT(IPM)/FPG
  2961.     IPAG=FPG
  2962.     IPAG=MOD(IPAG,IPM)
  2963.     IPAG=IPAG+1
  2964. C    IPAG=1+(IHASH*IPM)/18060
  2965. 3401    CONTINUE
  2966. C        IF(IPAG.LE.0)IPAG=1
  2967.     IF(IPAG.EQ.MPAG(1).OR.IPAG.EQ.MPAG(2))GOTO 850
  2968.     IF(MPAG(1).NE.0)GOTO 851
  2969.     MPAG(1)=IPAG
  2970.     GOTO 850
  2971. 851    IF(MPAG(2).EQ.0)MPAG(2)=IPAG
  2972. 850    CONTINUE
  2973.     IF(MPAG(1).EQ.IPAG)GOTO 852
  2974.     IF(MPAG(2).NE.IPAG)GOTO 853
  2975. C MPAG(2) = IPAG
  2976.     MVLAST=2
  2977.     MVBASE=400
  2978.     GOTO 1000
  2979. 852    CONTINUE
  2980.     MVLAST=1
  2981.     MVBASE=0
  2982.     GOTO 1000
  2983. 853    CONTINUE
  2984. C NEED NEW PAGE. FIX TO USE LEAST RECENTLY USED PAGE FOR SWAPOUT.
  2985.     MVLAST=3-MVLAST
  2986. C MVLAST = 1 OR 2
  2987.     MVBASE=400-MVBASE
  2988. C MVBASE = 0 OR 400. INITIALLY 0.
  2989. C        IF(MPAG.EQ.0)MPAG=IPAG
  2990. C THE ABOVE ACCOUNTS FOR MEMORY FREE... WE TREAT FILE AS IPM
  2991. C "PAGES" THE SIZE OF THE MEMORY AREA EACH. THIS MAKES IT RELATIVELY
  2992. C EASY TO ALTER THE PROGRAM TO HANDLE MORE MEMORY TO THE EXTENT THE
  2993. C COMPILER AND MACHINE ALLOW.
  2994.     IF(IPGMAX.LE.8)GOTO 1000
  2995. C IF HERE, WE NEED A PAGE NOT IN MEMORY. SWAP THE CURRENT MEMORY PAGE
  2996. C TO DISK AND BRING IN THE ONE DESIRED.
  2997. C FILES ARE OPENED ALREADY HERE... USE LUN 9 HERE.
  2998.         IRCLO=(MPAG(MVLAST)-1)*IBF+1
  2999.         IRCHI=MPAG(MVLAST)*IBF
  3000.         L=1+MVBASE
  3001.         DO 500 N=IRCLO,IRCHI
  3002.     IF(MPMOD(MVLAST).EQ.0)GOTO 500
  3003.         LLL=L+49
  3004.         WRITE(13,REC=N,ERR=500)((LVALBF(KK,K),KK=1,5),K=L,LLL)
  3005.         L=L+50
  3006. 500     CONTINUE
  3007. C MARK NEW PAGE MODIFIED SINCE WE WILL TOUCH IT HERE
  3008.     MPMOD(MVLAST)=1
  3009.         MPAG(MVLAST)=IPAG
  3010. C NOW READ IN THE DESIRED RECORD, HAVING SET THE DESIRED IN-MEMORY FLAG
  3011.         IRCLO=(MPAG(MVLAST)-1)*IBF+1
  3012.         IRCHI=MPAG(MVLAST)*IBF
  3013.         L=1+MVBASE
  3014.         DO 501 N=IRCLO,IRCHI
  3015.         LLL=L+49
  3016.         READ(13,REC=N,END=501,ERR=501)((LVALBF(KK,K),KK=1,5),K=L,LLL)
  3017.         L=L+50
  3018. 501     CONTINUE
  3019. 1000    CONTINUE
  3020. C NOW THE PAGE NEEDED IS IN MEMORY (OR MAY HAVE BEEN ALL ALONG)
  3021. C SET THE VALUE INTO IT AS REQUIRED...
  3022. C NOW START LOOKING AT HASH ADDRESS FOR VARIABLE...LINEAR SEARCH AFTERWARDS
  3023.     MPMOD(MVLAST)=1
  3024.     IF(NXINI.NE.0)GOTO 111
  3025.         IH1=JHASH-1
  3026.         DO 1 MMN=JHASH,400
  3027.     N=MMN+MVBASE
  3028. C WHILE ZEROING THE ARRAY, START AT THE HASH ADDRESS AND STOP THE ZEROING
  3029. C ONCE WE ENCOUNTER A VIRGIN RECORD. THIS WILL HOPEFULLY REDUCE OVERALL
  3030. C TIME MOST TIMES FOR ZEROING THE ARRAY.
  3031.     KKKKK=LVALBF(1,N)
  3032.     IF(KKKKK.EQ.-1)GOTO 111
  3033.         IF(KKKKK.NE.ID)GOTO 1
  3034. C ZERO ALL REFS TO THIS CELL WE'RE ABOUT TO WRITE.
  3035. C **** THIS IS QUITE TIME CONSUMING... OMIT IF POSSIBLE...
  3036.         LVALBF(1,N)=0
  3037. 1       CONTINUE
  3038.         IF(IH1.LT.1)RETURN
  3039.         DO 33 MMN=1,IH1
  3040.     N=MMN+MVBASE
  3041.     NN=N
  3042.     KKKKK=LVALBF(1,N)
  3043.     IF(KKKKK.EQ.-1)GOTO 111
  3044.         IF(KKKKK.NE.ID)GOTO 33
  3045.     LVALBF(1,N)=0
  3046. 33    CONTINUE
  3047. 111    CONTINUE
  3048. C SINCE ZERO VALUES ARE RETURNED BY DEFAULT, DON'T BOTHER STORING THEM
  3049.     IF(XX.EQ.0.)RETURN
  3050.         IH1=JHASH-1
  3051.         DO 2 MMN=JHASH,400
  3052.     N=MMN+MVBASE
  3053.     NN=N
  3054.     KKKKK=LVALBF(1,N)
  3055.     IF(KKKKK.EQ.-1)GOTO 4
  3056.         IF(KKKKK.EQ.0)GOTO 4
  3057.     IF(KKKKK.EQ.ID)GOTO 4
  3058. 2       CONTINUE
  3059.         IF(IH1.LT.1)RETURN
  3060.         DO 3 MMN=1,IH1
  3061.     N=MMN+MVBASE
  3062.     NN=N
  3063. C LOOK BEFORE THE HASHCODE IF NO FREE CELLS AFTER IT.
  3064.     KKKKK=LVALBF(1,N)
  3065.     IF(KKKKK.EQ.-1)GOTO 4
  3066.         IF(KKKKK.EQ.0)GOTO 4
  3067.     IF(KKKKK.EQ.ID)GOTO 4
  3068. 3       CONTINUE
  3069. C TELL USER VALUE AREA OVERFLOWED, USING ROW 1 END
  3070.     CALL UVT100(1,1,1)
  3071.     CALL SWRT('Value Table Storage overflowed. Try larger file.',48)
  3072.         RETURN
  3073. C RETURN IF CAN'T FIND VALUE...TOO BAD
  3074.  
  3075. 4       CONTINUE
  3076. C SAVE VALUE AS 4 16-BIT WORDS
  3077.         XA=XX
  3078. C SAVE ID AND VALUE IN CELL...
  3079.     LVALBF(1,NN)=ID
  3080.         DO 5 M=1,4
  3081. 5       LVALBF(M+1,NN)=LL(M)
  3082.         RETURN
  3083.         END
  3084. c -h- zero.for    Fri Aug 22 13:46:23 1986    
  3085.     SUBROUTINE ZERO
  3086. C COPYRIGHT (C) 1983 GLENN EVERHART
  3087. C ALL RIGHTS RESERVED
  3088. C 60=MAX REAL ROWS
  3089. C 301=MAX REAL COLS
  3090. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  3091. C VBLS AND TYPE DIMENSIONED 60,301
  3092. C **************************************************
  3093. C *                                                *
  3094. C *         SUBROUTINE  ZERO                       *
  3095. C *                                                *
  3096. C **************************************************
  3097. C
  3098. C
  3099. C
  3100. C  ZEROS OUT ALL VARIABLES EXCEPT %
  3101. C
  3102. C
  3103. C ZERO CALLS IABS
  3104. C
  3105. C
  3106. C ZERO IS CALLED BY CMND
  3107. C
  3108. C
  3109. C
  3110. C   VARIABLE    USE
  3111. C
  3112. C      I      POINTS TO VARIABLE
  3113. C      J      INDEXES DOWN ELEMENTS OF A VARIABLE
  3114. C
  3115. C
  3116. C
  3117. C    SUBROUTINE ZERO
  3118. C
  3119.     InTeGer*4  TYPE(1,1),VLEN(9)
  3120. C
  3121.     CHARACTER*1  AVBLS(20,27)
  3122.     CHARACTER*1 VBLS(8,1,1)
  3123. C
  3124.     COMMON  /V/TYPE,AVBLS,VBLS,VLEN
  3125. C
  3126. C
  3127. C
  3128. C JUST ZERO THE ACCUMULATORS HERE ... LEAVE REGULAR SHEET STUFF ALONE.
  3129. C    TYPE(1,1)=IABS(TYPE(1,1))
  3130.     VBLS(1,1,1)=0
  3131. C ZERO OUT ACCUMULATORS
  3132.     DO 1 I=1,27
  3133.     DO 1 J=1,20
  3134. 1    AVBLS(J,I)=0
  3135.     RETURN
  3136.     END
  3137. c -h- zneg.for    Fri Aug 22 13:46:23 1986    
  3138.     INTEGER FUNCTION ZNEG(INDXX)
  3139. C COPYRIGHT (C) 1983 GLENN EVERHART
  3140. C ALL RIGHTS RESERVED
  3141. C 60=MAX REAL ROWS
  3142. C 301=MAX REAL COLS
  3143. C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
  3144. C VBLS AND TYPE DIMENSIONED 60,301
  3145. C **************************************************
  3146. C *                                                *
  3147. C *        InTeGer*4 FUNCTION ZNEG(INDXX)          *
  3148. C *                                                *
  3149. C **************************************************
  3150. C
  3151. C DETERMINES IF VARIABLE POINTED TO BY INDXX IS ZERO OR NEGATIVE
  3152. C OR UNDEFINED AS OPPOSED TO BEING DEFINED AND POSITIVE
  3153. C
  3154. C     RETURNS      1   IF TRUE (ZERO OR NEGATIVE OR UNDEFINED)
  3155. C                  0   IF FALSE (POSITIVE)
  3156. C
  3157. C ZNEG CALLS ERRMSG TO PRINT ERROR MESSAGES.
  3158. C
  3159. C ZNEG IS CALLED BY CALC AND CMND.
  3160. C
  3161. C   VARIABLE       USE
  3162. C
  3163. C     INDXX      POINTER TO VARIABLE BEING TESTED
  3164. C     I,K        HOLDS TEMPORARY VALUES
  3165. C     ZNEG       RETURN VALUE
  3166. C     INT        HOLD INTEGER*4 VALUES
  3167. C     REAL       HOLD REAL*8 VALUES
  3168. C
  3169. C
  3170. C
  3171. C    INTEGER FUNCTION ZNEG*4(INDXX)
  3172.     REAL*8 REAL
  3173. C
  3174.     INTEGER*4 INT
  3175. C
  3176.     InTeGer*4 TYPE(1,1),VLEN(9),INDXX
  3177. C
  3178.     CHARACTER*1 AVBLS(20,27),FOUR(4),EIGHT(8)
  3179.     CHARACTER*1 VBLS(8,1,1)
  3180. C
  3181.     EQUIVALENCE (EIGHT,REAL),(FOUR,INT)
  3182. C
  3183.     COMMON/V/ TYPE,AVBLS,VBLS,VLEN
  3184. C
  3185. C DEFAULT SETTING OF TRUE
  3186.     ZNEG=1
  3187.     CALL TYPGET(INDXX,1,K)
  3188. C    K=TYPE(INDXX,1)
  3189.     IF(K.GT.0)GO TO 50
  3190. C
  3191. C VARIABLE UNDEFINED
  3192.     CALL UVT100(1,1,1)
  3193.     CALL SWRT('Undefined Vbl',13)
  3194. C    CALL ERRMSG(16)
  3195.     GO TO 10000
  3196. C
  3197. 50    GOTO(100,200,300,300,400,400,400,300,200),K
  3198.     STOP 50
  3199. C
  3200. C ASCII
  3201. 100    IF(AVBLS(1,INDXX).LE.0)GO TO 10000
  3202.     GO TO 9998
  3203. C
  3204. C DECIMAL AND REAL
  3205. 200    DO 210 I=1,8
  3206. 210    EIGHT(I)=AVBLS(I,INDXX)
  3207.     IF(REAL.LE.0.D0)GO TO 10000
  3208.     GO TO 9998
  3209. C
  3210. C INTEGER, HEX, AND OCTAL
  3211. 300    DO 310 I=1,4
  3212. 310    FOUR(I)=AVBLS(I,INDXX)
  3213.     IF(INT.LE.0)GO TO 10000
  3214.     GO TO 9998
  3215. C
  3216. C MULTIPLE PRECISION
  3217. 400    IF(ICHAR(AVBLS(20,INDXX)).NE.0) GOTO 10000
  3218.     GO TO 9998
  3219. C
  3220. 9998    ZNEG=0
  3221. 10000    RETURN
  3222.     END
  3223.